path: root/src/FundLab.Domain/Ledger.fs

namespace FundLab.Domain

open System

type ResidualOwner =
    | FundReserve
    | ExternalParty

type ResidualState =
    | Clear
    | RequiresAllocation of decimal
    | Allocated of decimal * ResidualOwner

type Holding =
    {
        InstrumentId: Guid
        AvailableUnits: decimal
        FrozenUnits: decimal
        SettledValue: decimal
    }

type BalanceSheet =
    {
        AvailableCash: decimal
        FrozenCash: decimal
        SettledHoldingsValue: decimal
        RedemptionReceivable: decimal
        OtherInTransitAssets: decimal
        Assets: decimal
        RedemptionPayable: decimal
        SubscriptionRefundPayable: decimal
        FeePayable: decimal
        OtherInTransitLiabilities: decimal
        Liabilities: decimal
        NetAssets: decimal
    }

type CashFlowKind =
    | ExternalDeposit
    | ExternalRedemption
    | ExternalRedemptionPayment
    | UnderlyingPurchase
    | UnderlyingRedemption
    | UnderlyingRedemptionReceipt

type CashFlow =
    {
        TransactionId: Guid
        FundId: Guid
        Kind: CashFlowKind
        EffectiveAt: DateTimeOffset
        GrossCash: decimal
        CreditedCash: decimal
        ConvertedUnits: decimal
        UnitNav: decimal option
        RoundingResidual: decimal
        ResidualOwner: ResidualOwner option
        IsSynthetic: bool
    }

type ExternalRedemptionStatus =
    | PendingPayment
    | Paid

type ExternalRedemptionRecord =
    {
        TransactionId: Guid
        FundId: Guid
        IdempotencyKey: string
        Units: decimal
        UnitNav: decimal
        PayableCash: decimal
        Status: ExternalRedemptionStatus
        ConfirmedAt: DateTimeOffset
        PaidAt: DateTimeOffset option
        IsSynthetic: bool
    }

type ResidualAllocationRecord =
    {
        TransactionId: Guid
        FundId: Guid
        Amount: decimal
        Owner: ResidualOwner
        EffectiveAt: DateTimeOffset
        IsSynthetic: bool
    }

type LedgerEvent =
    {
        TransactionId: Guid
        FundId: Guid
        EventType: string
        EffectiveAt: DateTimeOffset
        CashAmount: decimal
        Units: decimal
        RoundingResidual: decimal
        ResidualOwner: ResidualOwner option
        IsSynthetic: bool
    }

type LedgerOrderKind =
    | Purchase
    | Redemption

type LedgerOrder =
    {
        Id: Guid
        FundId: Guid
        InstrumentId: Guid
        Kind: LedgerOrderKind
        IdempotencyKey: string
        Status: OrderStatus
        RequestedCash: decimal
        RequestedUnits: decimal
        ConfirmedCash: decimal
        ConfirmedUnits: decimal
        RoundingResidual: decimal
        ResidualOwner: ResidualOwner option
        IsSynthetic: bool
        SubmittedAt: DateTimeOffset
        ConfirmedAt: DateTimeOffset option
    }

type LedgerFund =
    {
        Id: Guid
        Name: string
        Currency: string
        InitialCash: decimal
        InitialUnitNav: decimal
        IsSynthetic: bool
        AvailableCash: decimal
        FrozenCash: decimal
        Holdings: Map<Guid, Holding>
        OutstandingUnits: decimal
        RedemptionPayable: decimal
        RedemptionReceivable: decimal
        OtherInTransitAssets: decimal
        SubscriptionRefundPayable: decimal
        FeePayable: decimal
        OtherInTransitLiabilities: decimal
        Status: FundStatus
        Orders: Map<Guid, LedgerOrder>
        ExternalRedemptions: Map<Guid, ExternalRedemptionRecord>
        CashFlows: CashFlow list
        Events: LedgerEvent list
        ResidualAllocations: ResidualAllocationRecord list
        ResidualState: ResidualState
    }
    with
        member this.SettledHoldingsValue =
            this.Holdings
            |> Map.toSeq
            |> Seq.sumBy (fun (_, holding) -> holding.SettledValue)

        member this.balanceSheet =
            let settledHoldingsValue = this.SettledHoldingsValue
            let assets =
                this.AvailableCash
                + this.FrozenCash
                + settledHoldingsValue
                + this.RedemptionReceivable
                + this.OtherInTransitAssets

            let liabilities =
                this.RedemptionPayable
                + this.SubscriptionRefundPayable
                + this.FeePayable
                + this.OtherInTransitLiabilities

            {
                AvailableCash = this.AvailableCash
                FrozenCash = this.FrozenCash
                SettledHoldingsValue = settledHoldingsValue
                RedemptionReceivable = this.RedemptionReceivable
                OtherInTransitAssets = this.OtherInTransitAssets
                Assets = assets
                RedemptionPayable = this.RedemptionPayable
                SubscriptionRefundPayable = this.SubscriptionRefundPayable
                FeePayable = this.FeePayable
                OtherInTransitLiabilities = this.OtherInTransitLiabilities
                Liabilities = liabilities
                NetAssets = assets - liabilities
            }

        member this.BalanceSheet = this.balanceSheet
        member this.NetAssets = this.balanceSheet.NetAssets
        member this.UnitNavStatus =
            if this.OutstandingUnits = 0m then
                UnitNavStatus.ZeroUnits
            else
                UnitNavStatus.HasValue (this.NetAssets / this.OutstandingUnits)

type LedgerState =
    {
        Funds: Map<Guid, LedgerFund>
        Idempotencies: Map<Guid * string, string>
    }

type LedgerError =
    | FundNotFound of Guid
    | FundAlreadyExists of Guid
    | OrderNotFound of Guid
    | ExternalRedemptionNotFound of Guid
    | IdempotencyConflict of string
    | InvalidIdentifier of string
    | InvalidAmount of string
    | InvalidPrecision of string
    | InvalidState of string
    | TransactionAlreadyExists of Guid
    | InsufficientCash of decimal
    | InsufficientUnits of decimal
    | ResidualOwnershipRequired of decimal

module Ledger =
    type private ResultBuilder() =
        member _.Bind(result, binder) = Result.bind binder result
        member _.Return(value) = Ok value
        member _.ReturnFrom(result) = result
        member _.Zero() = Ok()
        member _.Combine(first, second) = Result.bind (fun () -> second) first
        member _.Delay(generator) = generator()

    let private result = ResultBuilder()

    [<Literal>]
    let CashScale = 2

    [<Literal>]
    let UnitScale = 8

    let empty =
        {
            Funds = Map.empty
            Idempotencies = Map.empty
        }

    let private decimalScale value =
        let bits = Decimal.GetBits(value)
        int ((bits[3] >>> 16) &&& 0x7f)

    let private roundDown scale value =
        Decimal.Round(value, scale, MidpointRounding.ToZero)

    let private validateNonNegative label scale value =
        if value < 0m then
            Error(InvalidAmount label)
        elif decimalScale value > scale then
            Error(InvalidPrecision label)
        else
            Ok()

    let private validatePositive label scale value =
        validateNonNegative label scale value
        |> Result.bind (fun () ->
            if value = 0m then
                Error(InvalidAmount label)
            else
                Ok())

    let private fundStatus outstandingUnits =
        if outstandingUnits = 0m then
            FundStatus.ZeroUnits
        else
            FundStatus.Active

    let getFund fundId state =
        match state.Funds |> Map.tryFind fundId with
        | Some fund -> Ok fund
        | None -> Error(FundNotFound fundId)

    let private updateFund fund state =
        { state with Funds = state.Funds |> Map.add fund.Id fund }

    let private validateIdentifier label value =
        if value = Guid.Empty then
            Error(InvalidIdentifier label)
        else
            Ok()

    let private transactionExists transactionId fund =
        fund.Events |> List.exists (fun event -> event.TransactionId = transactionId)
        || fund.CashFlows |> List.exists (fun cashFlow -> cashFlow.TransactionId = transactionId)
        || fund.ExternalRedemptions |> Map.containsKey transactionId
        || fund.ResidualAllocations |> List.exists (fun allocation -> allocation.TransactionId = transactionId)

    let private ensureTransactionIsNew transactionId fund =
        if transactionExists transactionId fund then
            Error(TransactionAlreadyExists transactionId)
        else
            Ok()

    let private addResidual residual residualState =
        if residual = 0m then
            residualState
        else
            match residualState with
            | Clear -> RequiresAllocation residual
            | RequiresAllocation existing -> RequiresAllocation(existing + residual)
            | Allocated _ -> RequiresAllocation residual

    let private runIdempotent fundId key fingerprint state action =
        if fundId = Guid.Empty then
            Error(InvalidIdentifier "fund id")
        elif String.IsNullOrWhiteSpace key then
            Error(InvalidState "idempotency key cannot be empty")
        else
            match state.Idempotencies |> Map.tryFind (fundId, key) with
            | Some previous when previous = fingerprint -> Ok state
            | Some _ -> Error(IdempotencyConflict key)
            | None ->
                action state
                |> Result.map (fun next ->
                    {
                        next with
                            Idempotencies = next.Idempotencies |> Map.add (fundId, key) fingerprint
                    })

    let initializeFund fundId name initialCash initialUnitNav isSynthetic state =
        result {
            do! validateIdentifier "fund id" fundId
            do! validateNonNegative "initial cash" CashScale initialCash
            do! validatePositive "initial unit NAV" UnitScale initialUnitNav

            if String.IsNullOrWhiteSpace name then
                return! Error(InvalidState "fund name cannot be empty")

            if state.Funds |> Map.containsKey fundId then
                return! Error(FundAlreadyExists fundId)

            let fund =
                {
                    Id = fundId
                    Name = name
                    Currency = "CNY"
                    InitialCash = initialCash
                    InitialUnitNav = initialUnitNav
                    IsSynthetic = isSynthetic
                    AvailableCash = initialCash
                    FrozenCash = 0m
                    Holdings = Map.empty
                    OutstandingUnits = 0m
                    RedemptionPayable = 0m
                    RedemptionReceivable = 0m
                    OtherInTransitAssets = 0m
                    SubscriptionRefundPayable = 0m
                    FeePayable = 0m
                    OtherInTransitLiabilities = 0m
                    Status = FundStatus.Empty
                    Orders = Map.empty
                    ExternalRedemptions = Map.empty
                    CashFlows = []
                    Events = []
                    ResidualAllocations = []
                    ResidualState = Clear
                }

            return updateFund fund state
        }

    let private canIssueUnits fund =
        match fund.ResidualState with
        | RequiresAllocation residual when fund.OutstandingUnits = 0m ->
            Error(ResidualOwnershipRequired residual)
        | _ -> Ok()

    let private addEvent transactionId eventType at cashAmount units residual owner isSynthetic fund =
        {
            fund with
                Events =
                    {
                        TransactionId = transactionId
                        FundId = fund.Id
                        EventType = eventType
                        EffectiveAt = at
                        CashAmount = cashAmount
                        Units = units
                        RoundingResidual = residual
                        ResidualOwner = owner
                        IsSynthetic = isSynthetic
                    }
                    :: fund.Events
        }

    let confirmExternalDeposit fundId transactionId idempotencyKey grossCash unitNav effectiveAt isSynthetic state =
        let fingerprint = sprintf "external-deposit|%O|%M|%M|%O|%b" transactionId grossCash unitNav effectiveAt isSynthetic

        runIdempotent fundId idempotencyKey fingerprint state (fun current ->
            result {
                do! validateIdentifier "transaction id" transactionId
                do! validatePositive "external deposit cash" CashScale grossCash
                do! validatePositive "external deposit unit NAV" UnitScale unitNav

                let! fund = getFund fundId current
                do! ensureTransactionIsNew transactionId fund
                do! canIssueUnits fund

                let convertedUnits = roundDown UnitScale (grossCash / unitNav)
                if convertedUnits = 0m then
                    return! Error(InvalidAmount "external deposit does not create units")

                let creditedCash = roundDown CashScale (convertedUnits * unitNav)
                let residual = grossCash - creditedCash
                let updatedFund =
                    {
                        fund with
                            AvailableCash = fund.AvailableCash + creditedCash
                            OutstandingUnits = fund.OutstandingUnits + convertedUnits
                            Status = FundStatus.Active
                            ResidualState = addResidual residual fund.ResidualState
                            CashFlows =
                                {
                                    TransactionId = transactionId
                                    FundId = fundId
                                    Kind = CashFlowKind.ExternalDeposit
                                    EffectiveAt = effectiveAt
                                    GrossCash = grossCash
                                    CreditedCash = creditedCash
                                    ConvertedUnits = convertedUnits
                                    UnitNav = Some unitNav
                                    RoundingResidual = residual
                                    ResidualOwner = None
                                    IsSynthetic = isSynthetic
                                }
                                :: fund.CashFlows
                    }
                    |> addEvent transactionId "external_deposit_confirmed" effectiveAt creditedCash convertedUnits residual None isSynthetic

                return updateFund updatedFund current
            })

    let private orderAlreadyExists orderId fund =
        if fund.Orders |> Map.containsKey orderId then
            Error(InvalidState "order already exists")
        else
            Ok()

    let private emptyHolding instrumentId =
        {
            InstrumentId = instrumentId
            AvailableUnits = 0m
            FrozenUnits = 0m
            SettledValue = 0m
        }

    let private addSettledHolding instrumentId units value holdings =
        let holding = holdings |> Map.tryFind instrumentId |> Option.defaultValue (emptyHolding instrumentId)

        holdings
        |> Map.add instrumentId {
            holding with
                AvailableUnits = holding.AvailableUnits + units
                SettledValue = holding.SettledValue + value
        }

    let private addCashFlow cashFlow fund =
        { fund with CashFlows = cashFlow :: fund.CashFlows }

    let private missingOrder orderId =
        Error(OrderNotFound orderId)

    let freezeUnderlyingPurchase fundId orderId idempotencyKey instrumentId requestedCash effectiveAt isSynthetic state =
        let fingerprint = sprintf "underlying-purchase-freeze|%O|%O|%M|%O|%b" orderId instrumentId requestedCash effectiveAt isSynthetic

        runIdempotent fundId idempotencyKey fingerprint state (fun current ->
            result {
                do! validateIdentifier "order id" orderId
                do! validateIdentifier "instrument id" instrumentId
                do! validatePositive "underlying purchase cash" CashScale requestedCash
                let! fund = getFund fundId current
                do! orderAlreadyExists orderId fund
                do! ensureTransactionIsNew orderId fund

                if fund.AvailableCash < requestedCash then
                    return! Error(InsufficientCash requestedCash)

                let order =
                    {
                        Id = orderId
                        FundId = fundId
                        InstrumentId = instrumentId
                        Kind = LedgerOrderKind.Purchase
                        IdempotencyKey = idempotencyKey
                        Status = OrderStatus.CashFrozen
                        RequestedCash = requestedCash
                        RequestedUnits = 0m
                        ConfirmedCash = 0m
                        ConfirmedUnits = 0m
                        RoundingResidual = 0m
                        ResidualOwner = None
                        IsSynthetic = isSynthetic
                        SubmittedAt = effectiveAt
                        ConfirmedAt = None
                    }

                let updatedFund =
                    {
                        fund with
                            AvailableCash = fund.AvailableCash - requestedCash
                            FrozenCash = fund.FrozenCash + requestedCash
                            Orders = fund.Orders |> Map.add orderId order
                    }
                    |> addEvent orderId "underlying_purchase_frozen" effectiveAt requestedCash 0m 0m None isSynthetic

                return updateFund updatedFund current
            })

    let confirmUnderlyingPurchase fundId orderId idempotencyKey confirmedUnits unitNav effectiveAt isSynthetic state =
        let fingerprint = sprintf "underlying-purchase-confirm|%O|%M|%M|%O|%b" orderId confirmedUnits unitNav effectiveAt isSynthetic

        runIdempotent fundId idempotencyKey fingerprint state (fun current ->
            result {
                do! validateIdentifier "order id" orderId
                do! validatePositive "underlying purchase units" UnitScale confirmedUnits
                do! validatePositive "underlying purchase unit NAV" UnitScale unitNav
                let! fund = getFund fundId current
                let! order = fund.Orders |> Map.tryFind orderId |> Option.map Ok |> Option.defaultValue (missingOrder orderId)

                if order.Kind <> LedgerOrderKind.Purchase || order.Status <> OrderStatus.CashFrozen then
                    return! Error(InvalidState "underlying purchase is not cash frozen")

                let grossCash = confirmedUnits * unitNav
                let confirmedCash = roundDown CashScale grossCash
                if confirmedCash <= 0m then
                    return! Error(InvalidAmount "underlying purchase cash rounds to zero")

                if confirmedCash > order.RequestedCash then
                    return! Error(InvalidState "underlying purchase exceeds frozen cash")

                let residual = grossCash - confirmedCash
                let updatedOrder =
                    {
                        order with
                            Status = OrderStatus.Confirmed
                            ConfirmedCash = confirmedCash
                            ConfirmedUnits = confirmedUnits
                            RoundingResidual = residual
                            ResidualOwner = None
                            ConfirmedAt = Some effectiveAt
                    }

                let updatedFund =
                    {
                        fund with
                            AvailableCash = fund.AvailableCash + order.RequestedCash - confirmedCash
                            FrozenCash = fund.FrozenCash - order.RequestedCash
                            Holdings = fund.Holdings |> addSettledHolding order.InstrumentId confirmedUnits confirmedCash
                            Orders = fund.Orders |> Map.add orderId updatedOrder
                            ResidualState = addResidual residual fund.ResidualState
                    }
                     |> addCashFlow {
                         TransactionId = orderId
                         FundId = fundId
                         Kind = CashFlowKind.UnderlyingPurchase
                         EffectiveAt = effectiveAt
                         GrossCash = grossCash
                         CreditedCash = confirmedCash
                         ConvertedUnits = confirmedUnits
                         UnitNav = Some unitNav
                         RoundingResidual = residual
                         ResidualOwner = None
                         IsSynthetic = isSynthetic
                     }
                     |> addEvent orderId "underlying_purchase_confirmed" effectiveAt confirmedCash confirmedUnits residual None isSynthetic

                return updateFund updatedFund current
            })

    let cancelUnderlyingPurchase fundId orderId idempotencyKey effectiveAt isSynthetic state =
        let fingerprint = sprintf "underlying-purchase-cancel|%O|%O|%b" orderId effectiveAt isSynthetic

        runIdempotent fundId idempotencyKey fingerprint state (fun current ->
            result {
                do! validateIdentifier "order id" orderId
                let! fund = getFund fundId current
                let! order = fund.Orders |> Map.tryFind orderId |> Option.map Ok |> Option.defaultValue (missingOrder orderId)

                if order.Kind <> LedgerOrderKind.Purchase || order.Status <> OrderStatus.CashFrozen then
                    return! Error(InvalidState "underlying purchase is not cancellable")

                let updatedOrder = { order with Status = OrderStatus.Cancelled }
                let updatedFund =
                    {
                        fund with
                            AvailableCash = fund.AvailableCash + order.RequestedCash
                            FrozenCash = fund.FrozenCash - order.RequestedCash
                            Orders = fund.Orders |> Map.add orderId updatedOrder
                    }
                    |> addEvent orderId "underlying_purchase_cancelled" effectiveAt order.RequestedCash 0m 0m None isSynthetic

                return updateFund updatedFund current
            })

    let freezeUnderlyingRedemption fundId orderId idempotencyKey instrumentId requestedUnits effectiveAt isSynthetic state =
        let fingerprint = sprintf "underlying-redemption-freeze|%O|%O|%M|%O|%b" orderId instrumentId requestedUnits effectiveAt isSynthetic

        runIdempotent fundId idempotencyKey fingerprint state (fun current ->
            result {
                do! validateIdentifier "order id" orderId
                do! validateIdentifier "instrument id" instrumentId
                do! validatePositive "underlying redemption units" UnitScale requestedUnits
                let! fund = getFund fundId current
                do! orderAlreadyExists orderId fund
                do! ensureTransactionIsNew orderId fund
                let! holding = fund.Holdings |> Map.tryFind instrumentId |> Option.map Ok |> Option.defaultValue (Error(InvalidState "holding not found"))

                if holding.AvailableUnits < requestedUnits then
                    return! Error(InsufficientUnits requestedUnits)

                let updatedHolding =
                    {
                        holding with
                            AvailableUnits = holding.AvailableUnits - requestedUnits
                            FrozenUnits = holding.FrozenUnits + requestedUnits
                    }

                let order =
                    {
                        Id = orderId
                        FundId = fundId
                        InstrumentId = instrumentId
                        Kind = LedgerOrderKind.Redemption
                        IdempotencyKey = idempotencyKey
                        Status = OrderStatus.UnitsFrozen
                        RequestedCash = 0m
                        RequestedUnits = requestedUnits
                        ConfirmedCash = 0m
                        ConfirmedUnits = 0m
                        RoundingResidual = 0m
                        ResidualOwner = None
                        IsSynthetic = isSynthetic
                        SubmittedAt = effectiveAt
                        ConfirmedAt = None
                    }

                let updatedFund =
                    {
                        fund with
                            Holdings = fund.Holdings |> Map.add instrumentId updatedHolding
                            Orders = fund.Orders |> Map.add orderId order
                    }
                    |> addEvent orderId "underlying_redemption_frozen" effectiveAt 0m requestedUnits 0m None isSynthetic

                return updateFund updatedFund current
            })

    let private releaseFrozenHolding holding units =
        let totalUnits = holding.AvailableUnits + holding.FrozenUnits
        let releasedValue =
            if units = totalUnits then
                holding.SettledValue
            else
                roundDown CashScale (holding.SettledValue * units / totalUnits)

        let remaining =
            {
                holding with
                    FrozenUnits = holding.FrozenUnits - units
                    SettledValue = holding.SettledValue - releasedValue
            }

        remaining, releasedValue

    let confirmUnderlyingRedemption fundId orderId idempotencyKey unitNav effectiveAt isSynthetic state =
        let fingerprint = sprintf "underlying-redemption-confirm|%O|%M|%O|%b" orderId unitNav effectiveAt isSynthetic

        runIdempotent fundId idempotencyKey fingerprint state (fun current ->
            result {
                do! validateIdentifier "order id" orderId
                do! validatePositive "underlying redemption unit NAV" UnitScale unitNav
                let! fund = getFund fundId current
                let! order = fund.Orders |> Map.tryFind orderId |> Option.map Ok |> Option.defaultValue (missingOrder orderId)

                if order.Kind <> LedgerOrderKind.Redemption || order.Status <> OrderStatus.UnitsFrozen then
                    return! Error(InvalidState "underlying redemption is not units frozen")

                let! holding = fund.Holdings |> Map.tryFind order.InstrumentId |> Option.map Ok |> Option.defaultValue (Error(InvalidState "holding not found"))
                if holding.FrozenUnits < order.RequestedUnits then
                    return! Error(InsufficientUnits order.RequestedUnits)

                let grossCash = order.RequestedUnits * unitNav
                let receivable = roundDown CashScale grossCash
                if receivable <= 0m then
                    return! Error(InvalidAmount "underlying redemption cash rounds to zero")

                let residual = grossCash - receivable
                let updatedHolding, _ = releaseFrozenHolding holding order.RequestedUnits
                let updatedHoldings =
                    if updatedHolding.AvailableUnits = 0m && updatedHolding.FrozenUnits = 0m then
                        fund.Holdings |> Map.remove order.InstrumentId
                    else
                        fund.Holdings |> Map.add order.InstrumentId updatedHolding

                let updatedOrder =
                    {
                        order with
                            Status = OrderStatus.Confirmed
                            ConfirmedCash = receivable
                            ConfirmedUnits = order.RequestedUnits
                            RoundingResidual = residual
                            ResidualOwner = None
                            ConfirmedAt = Some effectiveAt
                    }

                let updatedFund =
                    {
                        fund with
                            Holdings = updatedHoldings
                            RedemptionReceivable = fund.RedemptionReceivable + receivable
                            Orders = fund.Orders |> Map.add orderId updatedOrder
                            ResidualState = addResidual residual fund.ResidualState
                    }
                     |> addCashFlow {
                         TransactionId = orderId
                         FundId = fundId
                         Kind = CashFlowKind.UnderlyingRedemption
                         EffectiveAt = effectiveAt
                         GrossCash = grossCash
                         CreditedCash = receivable
                         ConvertedUnits = order.RequestedUnits
                         UnitNav = Some unitNav
                         RoundingResidual = residual
                         ResidualOwner = None
                         IsSynthetic = isSynthetic
                     }
                     |> addEvent orderId "underlying_redemption_confirmed" effectiveAt receivable order.RequestedUnits residual None isSynthetic

                return updateFund updatedFund current
            })

    let receiveUnderlyingRedemption fundId orderId idempotencyKey effectiveAt isSynthetic state =
        let fingerprint = sprintf "underlying-redemption-receive|%O|%O|%b" orderId effectiveAt isSynthetic

        runIdempotent fundId idempotencyKey fingerprint state (fun current ->
            result {
                do! validateIdentifier "order id" orderId
                let! fund = getFund fundId current
                let! order = fund.Orders |> Map.tryFind orderId |> Option.map Ok |> Option.defaultValue (missingOrder orderId)

                if order.Kind <> LedgerOrderKind.Redemption || order.Status <> OrderStatus.Confirmed then
                    return! Error(InvalidState "underlying redemption is not confirmed")

                if fund.RedemptionReceivable < order.ConfirmedCash then
                    return! Error(InvalidState "underlying redemption receivable is unavailable")

                let updatedOrder = { order with Status = OrderStatus.Settled }
                let updatedFund =
                    {
                        fund with
                            AvailableCash = fund.AvailableCash + order.ConfirmedCash
                            RedemptionReceivable = fund.RedemptionReceivable - order.ConfirmedCash
                            Orders = fund.Orders |> Map.add orderId updatedOrder
                    }
                    |> addCashFlow {
                        TransactionId = orderId
                        FundId = fundId
                        Kind = CashFlowKind.UnderlyingRedemptionReceipt
                        EffectiveAt = effectiveAt
                        GrossCash = order.ConfirmedCash
                        CreditedCash = order.ConfirmedCash
                        ConvertedUnits = 0m
                        UnitNav = None
                        RoundingResidual = 0m
                        ResidualOwner = None
                        IsSynthetic = isSynthetic
                    }
                    |> addEvent orderId "underlying_redemption_received" effectiveAt order.ConfirmedCash 0m 0m None isSynthetic

                return updateFund updatedFund current
            })

    let allocateResidual fundId transactionId idempotencyKey owner effectiveAt isSynthetic state =
        let fingerprint = sprintf "residual-allocation|%O|%A|%O|%b" transactionId owner effectiveAt isSynthetic

        runIdempotent fundId idempotencyKey fingerprint state (fun current ->
            result {
                do! validateIdentifier "transaction id" transactionId
                let! fund = getFund fundId current

                match fund.ResidualState with
                | RequiresAllocation residual ->
                    if fund.OutstandingUnits <> 0m then
                        return! Error(InvalidState "residual allocation requires zero outstanding units")

                    do! ensureTransactionIsNew transactionId fund
                    let allocation =
                        {
                            TransactionId = transactionId
                            FundId = fundId
                            Amount = residual
                            Owner = owner
                            EffectiveAt = effectiveAt
                            IsSynthetic = isSynthetic
                        }

                    let updatedFund =
                        {
                            fund with
                                ResidualState = Allocated(residual, owner)
                                ResidualAllocations = allocation :: fund.ResidualAllocations
                        }
                        |> addEvent transactionId "residual_allocated" effectiveAt 0m 0m residual (Some owner) isSynthetic

                    return updateFund updatedFund current
                | _ ->
                    return! Error(InvalidState "no residual requires allocation")
            })

    let confirmExternalRedemption fundId transactionId idempotencyKey units unitNav effectiveAt isSynthetic state =
        let fingerprint = sprintf "external-redemption|%O|%M|%M|%O|%b" transactionId units unitNav effectiveAt isSynthetic

        runIdempotent fundId idempotencyKey fingerprint state (fun current ->
            result {
                do! validateIdentifier "transaction id" transactionId
                do! validatePositive "external redemption units" UnitScale units
                do! validatePositive "external redemption unit NAV" UnitScale unitNav

                let! fund = getFund fundId current
                do! ensureTransactionIsNew transactionId fund
                if fund.OutstandingUnits < units then
                    return! Error(InsufficientUnits units)

                let grossCash = units * unitNav
                let payableCash = roundDown CashScale grossCash
                if payableCash = 0m then
                    return! Error(InvalidAmount "external redemption cash rounds to zero")

                let residual = grossCash - payableCash
                let redemption =
                    {
                        TransactionId = transactionId
                        FundId = fundId
                        IdempotencyKey = idempotencyKey
                        Units = units
                        UnitNav = unitNav
                        PayableCash = payableCash
                        Status = ExternalRedemptionStatus.PendingPayment
                        ConfirmedAt = effectiveAt
                        PaidAt = None
                        IsSynthetic = isSynthetic
                    }

                let updatedFund =
                    {
                        fund with
                            OutstandingUnits = fund.OutstandingUnits - units
                            RedemptionPayable = fund.RedemptionPayable + payableCash
                            Status = fundStatus (fund.OutstandingUnits - units)
                            ResidualState = addResidual residual fund.ResidualState
                            ExternalRedemptions = fund.ExternalRedemptions |> Map.add transactionId redemption
                            CashFlows =
                                {
                                    TransactionId = transactionId
                                    FundId = fundId
                                    Kind = CashFlowKind.ExternalRedemption
                                    EffectiveAt = effectiveAt
                                    GrossCash = grossCash
                                    CreditedCash = payableCash
                                    ConvertedUnits = units
                                    UnitNav = Some unitNav
                                    RoundingResidual = residual
                                    ResidualOwner = None
                                    IsSynthetic = isSynthetic
                                }
                                :: fund.CashFlows
                    }
                    |> addEvent transactionId "external_redemption_confirmed" effectiveAt payableCash units residual None isSynthetic

                return updateFund updatedFund current
            })

    let payExternalRedemption fundId transactionId idempotencyKey effectiveAt isSynthetic state =
        let fingerprint = sprintf "external-redemption-payment|%O|%O|%b" transactionId effectiveAt isSynthetic

        runIdempotent fundId idempotencyKey fingerprint state (fun current ->
            result {
                do! validateIdentifier "transaction id" transactionId
                let! fund = getFund fundId current
                let! redemption =
                    fund.ExternalRedemptions
                    |> Map.tryFind transactionId
                    |> Option.map Ok
                    |> Option.defaultValue (Error(ExternalRedemptionNotFound transactionId))

                if redemption.Status <> ExternalRedemptionStatus.PendingPayment then
                    return! Error(InvalidState "external redemption is already paid")

                let payable = redemption.PayableCash

                if fund.AvailableCash < payable then
                    return! Error(InsufficientCash payable)

                let updatedRedemption = { redemption with Status = ExternalRedemptionStatus.Paid; PaidAt = Some effectiveAt }

                let updatedFund =
                    {
                        fund with
                            AvailableCash = fund.AvailableCash - payable
                            RedemptionPayable = fund.RedemptionPayable - payable
                            ExternalRedemptions = fund.ExternalRedemptions |> Map.add transactionId updatedRedemption
                            CashFlows =
                                {
                                    TransactionId = transactionId
                                    FundId = fundId
                                    Kind = CashFlowKind.ExternalRedemptionPayment
                                    EffectiveAt = effectiveAt
                                    GrossCash = payable
                                    CreditedCash = payable
                                    ConvertedUnits = 0m
                                    UnitNav = None
                                    RoundingResidual = 0m
                                    ResidualOwner = None
                                    IsSynthetic = isSynthetic
                                }
                                :: fund.CashFlows
                    }
                    |> addEvent transactionId "external_redemption_paid" effectiveAt payable 0m 0m None isSynthetic

                return updateFund updatedFund current
            })