{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}

-- |
-- Copyright: © 2018-2020 IOHK
-- License: Apache-2.0
--
-- This module implements the "business logic" to manage a Cardano wallet.
-- It is a direct implementation of the model, with extensions, from the
-- [Formal Specification for a Cardano Wallet](https://github.com/input-output-hk/cardano-wallet/blob/master/specifications/wallet/formal-specification-for-a-cardano-wallet.pdf).
--
-- In other words, this module is about how the wallet keeps track of its
-- internal state, specifically the 'UTxO' set and the address discovery state.
-- This module is intentionally agnostic to specific address formats, and
-- instead relies on the 'IsOurs' abstraction.  It is also agnostic to issues
-- such as how blocks are retrieved from the network, or how the state is
-- serialized and cached in the local database.
--
-- All those functions are pure and there's no reason to shove in any sort of
-- side-effects in here. 🙂

module Cardano.Wallet.Primitive.Model
    (
    -- * Type
      Wallet

    -- * Construction & Modification
    , initWallet
    , updateState
    , FilteredBlock (..)
    , applyBlock
    , applyBlocks
    , applyBlockData

    , BlockData (..)
    , firstHeader
    , lastHeader

    -- * Accessors
    , currentTip
    , getState
    , availableBalance
    , totalBalance
    , totalUTxO
    , availableUTxO
    , utxo

    -- * Delta Type
    , DeltaWallet

    -- * Internal
    , unsafeInitWallet
    -- ** Exported for testing
    , spendTx
    , utxoFromTx
    , utxoFromTxOutputs
    , utxoFromTxCollateralOutputs
    , applyTxToUTxO
    , applyOurTxToUTxO
    , changeUTxO
    , discoverAddressesBlock
    , discoverFromBlockData
    , updateOurs
    ) where

import Prelude

import Cardano.Wallet.Primitive.AddressDiscovery
    ( DiscoverTxs (..), IsOurs (..) )
import Cardano.Wallet.Primitive.BlockSummary
    ( BlockEvents (..)
    , BlockSummary (..)
    , ChainEvents
    , fromBlockEvents
    , fromEntireBlock
    , toAscBlockEvents
    )
import Cardano.Wallet.Primitive.Types
    ( Block (..)
    , BlockHeader (..)
    , DelegationCertificate (..)
    , Slot
    , WithOrigin (..)
    , chainPointFromBlockHeader
    , dlgCertAccount
    , toSlot
    )
import Cardano.Wallet.Primitive.Types.Address
    ( Address (..) )
import Cardano.Wallet.Primitive.Types.Coin
    ( Coin (..), distance )
import Cardano.Wallet.Primitive.Types.RewardAccount
    ( RewardAccount (..) )
import Cardano.Wallet.Primitive.Types.TokenBundle
    ( TokenBundle )
import Cardano.Wallet.Primitive.Types.Tx
    ( Direction (..)
    , Tx (..)
    , TxIn (..)
    , TxMeta (..)
    , TxStatus (..)
    , collateralInputs
    , inputs
    , txOutCoin
    , txScriptInvalid
    )
import Cardano.Wallet.Primitive.Types.UTxO
    ( DeltaUTxO, UTxO (..), balance, excluding, excludingD, receiveD )
import Control.DeepSeq
    ( NFData (..), deepseq )
import Control.Monad.Trans.State.Strict
    ( State, evalState, state )
import Data.Bifunctor
    ( first )
import Data.Delta
    ( Delta (..) )
import Data.Foldable
    ( Foldable (toList) )
import Data.Functor.Identity
    ( Identity (..) )
import Data.Generics.Internal.VL.Lens
    ( (^.) )
import Data.List.NonEmpty
    ( NonEmpty (..) )
import Data.Maybe
    ( isJust )
import Data.Quantity
    ( Quantity )
import Data.Set
    ( Set )
import Data.Word
    ( Word32 )
import Fmt
    ( Buildable (..), indentF )
import GHC.Generics
    ( Generic )

import qualified Cardano.Wallet.Primitive.Types.TokenBundle as TB
import qualified Cardano.Wallet.Primitive.Types.UTxO as UTxO
import qualified Data.Delta as Delta
import qualified Data.Foldable as F
import qualified Data.List as L
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import qualified Data.Set as Set

{-------------------------------------------------------------------------------
                                      Type
-------------------------------------------------------------------------------}

-- | Abstract data type representing a wallet state.
--
-- A 'Wallet' keeps track of transaction outputs and associated addresses that
-- belong to /us/ -- we are able to spend these outputs because we know the
-- corresponding signing key belonging to the output. Hence, we are able to
-- produce witness engaging those outputs as they become inputs in forthcoming
-- transactions according to UTxO model.  This information is associated to a
-- particular point on the blockchain.
--
-- Internally, a 'Wallet' keeps track of
--
--  - UTxOs
--  - Known & used addresses, via address discovery state
--  - The associated 'BlockHeader' indicating the point on the chain.
--
-- The 'Wallet' is parameterized over a single type:
--
-- - @s@ is a /state/ used to keep track of known addresses.
--   Typically, this state will be an instance of the 'IsOurs' class,
--   e.g. @'IsOurs' s 'Address'@.
--
-- A few examples to make it concrete:
--
-- @
-- Wallet (RndState k n)
-- Wallet (SeqState n ShelleyKey)
-- @
data Wallet s = Wallet
    { -- | Unspent tx outputs belonging to this wallet
      Wallet s -> UTxO
utxo :: UTxO

      -- | Header of the latest applied block (current tip)
    , Wallet s -> BlockHeader
currentTip :: BlockHeader

      -- | Address discovery state
    , Wallet s -> s
getState :: s
    } deriving ((forall x. Wallet s -> Rep (Wallet s) x)
-> (forall x. Rep (Wallet s) x -> Wallet s) -> Generic (Wallet s)
forall x. Rep (Wallet s) x -> Wallet s
forall x. Wallet s -> Rep (Wallet s) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall s x. Rep (Wallet s) x -> Wallet s
forall s x. Wallet s -> Rep (Wallet s) x
$cto :: forall s x. Rep (Wallet s) x -> Wallet s
$cfrom :: forall s x. Wallet s -> Rep (Wallet s) x
Generic, Wallet s -> Wallet s -> Bool
(Wallet s -> Wallet s -> Bool)
-> (Wallet s -> Wallet s -> Bool) -> Eq (Wallet s)
forall s. Eq s => Wallet s -> Wallet s -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Wallet s -> Wallet s -> Bool
$c/= :: forall s. Eq s => Wallet s -> Wallet s -> Bool
== :: Wallet s -> Wallet s -> Bool
$c== :: forall s. Eq s => Wallet s -> Wallet s -> Bool
Eq, Int -> Wallet s -> ShowS
[Wallet s] -> ShowS
Wallet s -> String
(Int -> Wallet s -> ShowS)
-> (Wallet s -> String) -> ([Wallet s] -> ShowS) -> Show (Wallet s)
forall s. Show s => Int -> Wallet s -> ShowS
forall s. Show s => [Wallet s] -> ShowS
forall s. Show s => Wallet s -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Wallet s] -> ShowS
$cshowList :: forall s. Show s => [Wallet s] -> ShowS
show :: Wallet s -> String
$cshow :: forall s. Show s => Wallet s -> String
showsPrec :: Int -> Wallet s -> ShowS
$cshowsPrec :: forall s. Show s => Int -> Wallet s -> ShowS
Show)

instance NFData s => NFData (Wallet s) where
    rnf :: Wallet s -> ()
rnf (Wallet UTxO
u BlockHeader
sl s
s) =
        () -> () -> ()
forall a b. NFData a => a -> b -> b
deepseq (UTxO -> ()
forall a. NFData a => a -> ()
rnf UTxO
u) (() -> ()) -> () -> ()
forall a b. (a -> b) -> a -> b
$
        () -> () -> ()
forall a b. NFData a => a -> b -> b
deepseq (BlockHeader -> ()
forall a. NFData a => a -> ()
rnf BlockHeader
sl) (() -> ()) -> () -> ()
forall a b. (a -> b) -> a -> b
$
        () -> () -> ()
forall a b. NFData a => a -> b -> b
deepseq (s -> ()
forall a. NFData a => a -> ()
rnf s
s)
        ()

instance Buildable s => Buildable (Wallet s) where
    build :: Wallet s -> Builder
build (Wallet UTxO
u BlockHeader
tip s
s) = Builder
"Wallet s\n"
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder -> Builder
indentF Int
4 (Builder
"Tip: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> BlockHeader -> Builder
forall p. Buildable p => p -> Builder
build BlockHeader
tip)
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder -> Builder
indentF Int
4 (Builder
"UTxO:\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder -> Builder
indentF Int
4 (UTxO -> Builder
forall p. Buildable p => p -> Builder
build UTxO
u))
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder -> Builder
indentF Int
4 (s -> Builder
forall p. Buildable p => p -> Builder
build s
s)

-- | Delta encoding for 'Wallet'.
data DeltaWallet s = DeltaWallet
    { DeltaWallet s -> DeltaUTxO
deltaUTxO :: DeltaUTxO
    , DeltaWallet s -> Replace BlockHeader
deltaCurrentTip :: Delta.Replace BlockHeader
    , DeltaWallet s -> DeltaAddressBook s
deltaAddressBook :: DeltaAddressBook s
    } deriving (Int -> DeltaWallet s -> ShowS
[DeltaWallet s] -> ShowS
DeltaWallet s -> String
(Int -> DeltaWallet s -> ShowS)
-> (DeltaWallet s -> String)
-> ([DeltaWallet s] -> ShowS)
-> Show (DeltaWallet s)
forall s. Show s => Int -> DeltaWallet s -> ShowS
forall s. Show s => [DeltaWallet s] -> ShowS
forall s. Show s => DeltaWallet s -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DeltaWallet s] -> ShowS
$cshowList :: forall s. Show s => [DeltaWallet s] -> ShowS
show :: DeltaWallet s -> String
$cshow :: forall s. Show s => DeltaWallet s -> String
showsPrec :: Int -> DeltaWallet s -> ShowS
$cshowsPrec :: forall s. Show s => Int -> DeltaWallet s -> ShowS
Show)

type DeltaAddressBook s = Delta.Replace s

instance Delta (DeltaWallet s) where
    type Base (DeltaWallet s) = Wallet s
    DeltaWallet s
dw apply :: DeltaWallet s -> Base (DeltaWallet s) -> Base (DeltaWallet s)
`apply` Base (DeltaWallet s)
w = Base (DeltaWallet s)
Wallet s
w
        { $sel:utxo:Wallet :: UTxO
utxo = DeltaWallet s -> DeltaUTxO
forall s. DeltaWallet s -> DeltaUTxO
deltaUTxO DeltaWallet s
dw DeltaUTxO -> Base DeltaUTxO -> Base DeltaUTxO
forall delta. Delta delta => delta -> Base delta -> Base delta
`apply` Wallet s -> UTxO
forall s. Wallet s -> UTxO
utxo Base (DeltaWallet s)
Wallet s
w
        , $sel:currentTip:Wallet :: BlockHeader
currentTip = DeltaWallet s -> Replace BlockHeader
forall s. DeltaWallet s -> Replace BlockHeader
deltaCurrentTip DeltaWallet s
dw Replace BlockHeader
-> Base (Replace BlockHeader) -> Base (Replace BlockHeader)
forall delta. Delta delta => delta -> Base delta -> Base delta
`apply` Wallet s -> BlockHeader
forall s. Wallet s -> BlockHeader
currentTip Base (DeltaWallet s)
Wallet s
w
        , $sel:getState:Wallet :: s
getState = DeltaWallet s -> DeltaAddressBook s
forall s. DeltaWallet s -> DeltaAddressBook s
deltaAddressBook DeltaWallet s
dw DeltaAddressBook s
-> Base (DeltaAddressBook s) -> Base (DeltaAddressBook s)
forall delta. Delta delta => delta -> Base delta -> Base delta
`apply` Wallet s -> s
forall s. Wallet s -> s
getState Base (DeltaWallet s)
Wallet s
w
        }

{-------------------------------------------------------------------------------
                          Construction & Modification
-------------------------------------------------------------------------------}

-- | Create an empty wallet and apply the given genesis block.
--
-- The wallet tip will be the genesis block header.
initWallet
    :: (IsOurs s Address, IsOurs s RewardAccount)
    => Block
        -- ^ The genesis block
    -> s
        -- ^ Initial address discovery state
    -> ([(Tx, TxMeta)], Wallet s)
initWallet :: Block -> s -> ([(Tx, TxMeta)], Wallet s)
initWallet Block
block0 s
s = ([(Tx, TxMeta)]
transactions, Wallet s
w1)
  where
    w0 :: Wallet s
w0 = UTxO -> BlockHeader -> s -> Wallet s
forall s. UTxO -> BlockHeader -> s -> Wallet s
Wallet UTxO
forall a. Monoid a => a
mempty BlockHeader
forall a. HasCallStack => a
undefined s
s
    (FilteredBlock{[(Tx, TxMeta)]
$sel:transactions:FilteredBlock :: FilteredBlock -> [(Tx, TxMeta)]
transactions :: [(Tx, TxMeta)]
transactions}, (DeltaWallet s
_, Wallet s
w1)) = Block -> Wallet s -> (FilteredBlock, (DeltaWallet s, Wallet s))
forall s.
(IsOurs s Address, IsOurs s RewardAccount) =>
Block -> Wallet s -> (FilteredBlock, (DeltaWallet s, Wallet s))
applyBlock Block
block0 Wallet s
w0

-- | Construct a wallet from the exact given state.
--
-- Using this function instead of 'initWallet' and 'applyBlock' allows the
-- wallet invariants to be broken. Therefore it should only be used in the
-- special case of loading wallet checkpoints from the database (where it is
-- assumed a valid wallet was stored into the database).
unsafeInitWallet
    :: UTxO
       -- ^ Unspent tx outputs belonging to this wallet
    -> BlockHeader
    -- ^ Header of the latest applied block (current tip)
    -> s
    -- ^ Address discovery state
    -> Wallet s
unsafeInitWallet :: UTxO -> BlockHeader -> s -> Wallet s
unsafeInitWallet = UTxO -> BlockHeader -> s -> Wallet s
forall s. UTxO -> BlockHeader -> s -> Wallet s
Wallet

-- | Update the address discovery state of a wallet.
updateState
    :: s
    -> Wallet s
    -> Wallet s
updateState :: s -> Wallet s -> Wallet s
updateState s
s (Wallet UTxO
u BlockHeader
tip s
_) = UTxO -> BlockHeader -> s -> Wallet s
forall s. UTxO -> BlockHeader -> s -> Wallet s
Wallet UTxO
u BlockHeader
tip s
s

{-------------------------------------------------------------------------------
                    Applying Blocks to the wallet state
-------------------------------------------------------------------------------}

-- | Represents the subset of data from a single block that are relevant to a
-- particular wallet, discovered when applying a block to that wallet.
data FilteredBlock = FilteredBlock
    { FilteredBlock -> Slot
slot :: !Slot
        -- ^ The slot of this block.
    , FilteredBlock -> [(Tx, TxMeta)]
transactions :: ![(Tx, TxMeta)]
        -- ^ The set of transactions that affect the wallet,
        -- list in the same order which they appeared in the block.
    , FilteredBlock -> [DelegationCertificate]
delegations :: ![DelegationCertificate]
        -- ^ Stake delegations made on behalf of the wallet,
        -- listed in the order in which they appear on the chain.
        -- If the list contains more than element, those that appear
        -- later in the list supersede those that appear earlier on.
    } deriving ((forall x. FilteredBlock -> Rep FilteredBlock x)
-> (forall x. Rep FilteredBlock x -> FilteredBlock)
-> Generic FilteredBlock
forall x. Rep FilteredBlock x -> FilteredBlock
forall x. FilteredBlock -> Rep FilteredBlock x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep FilteredBlock x -> FilteredBlock
$cfrom :: forall x. FilteredBlock -> Rep FilteredBlock x
Generic, Int -> FilteredBlock -> ShowS
[FilteredBlock] -> ShowS
FilteredBlock -> String
(Int -> FilteredBlock -> ShowS)
-> (FilteredBlock -> String)
-> ([FilteredBlock] -> ShowS)
-> Show FilteredBlock
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FilteredBlock] -> ShowS
$cshowList :: [FilteredBlock] -> ShowS
show :: FilteredBlock -> String
$cshow :: FilteredBlock -> String
showsPrec :: Int -> FilteredBlock -> ShowS
$cshowsPrec :: Int -> FilteredBlock -> ShowS
Show, FilteredBlock -> FilteredBlock -> Bool
(FilteredBlock -> FilteredBlock -> Bool)
-> (FilteredBlock -> FilteredBlock -> Bool) -> Eq FilteredBlock
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FilteredBlock -> FilteredBlock -> Bool
$c/= :: FilteredBlock -> FilteredBlock -> Bool
== :: FilteredBlock -> FilteredBlock -> Bool
$c== :: FilteredBlock -> FilteredBlock -> Bool
Eq)

-- | Apply a single block to a wallet.
--
-- This is the most fundamental way of making a wallet evolve.
--
-- Returns an updated wallet, as well as the address data relevant to the wallet
-- that were discovered while applying the block.
applyBlock
    :: (IsOurs s Address, IsOurs s RewardAccount)
    => Block
    -> Wallet s
    -> (FilteredBlock, (DeltaWallet s, Wallet s))
applyBlock :: Block -> Wallet s -> (FilteredBlock, (DeltaWallet s, Wallet s))
applyBlock Block
block =
    ([FilteredBlock] -> FilteredBlock)
-> ([FilteredBlock], (DeltaWallet s, Wallet s))
-> (FilteredBlock, (DeltaWallet s, Wallet s))
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first [FilteredBlock] -> FilteredBlock
fromFiltered (([FilteredBlock], (DeltaWallet s, Wallet s))
 -> (FilteredBlock, (DeltaWallet s, Wallet s)))
-> (Wallet s -> ([FilteredBlock], (DeltaWallet s, Wallet s)))
-> Wallet s
-> (FilteredBlock, (DeltaWallet s, Wallet s))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity ([FilteredBlock], (DeltaWallet s, Wallet s))
-> ([FilteredBlock], (DeltaWallet s, Wallet s))
forall a. Identity a -> a
runIdentity (Identity ([FilteredBlock], (DeltaWallet s, Wallet s))
 -> ([FilteredBlock], (DeltaWallet s, Wallet s)))
-> (Wallet s
    -> Identity ([FilteredBlock], (DeltaWallet s, Wallet s)))
-> Wallet s
-> ([FilteredBlock], (DeltaWallet s, Wallet s))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockData Identity (Either Address RewardAccount) ChainEvents s
-> Wallet s
-> Identity ([FilteredBlock], (DeltaWallet s, Wallet s))
forall s (m :: * -> *).
(IsOurs s Address, IsOurs s RewardAccount, Monad m) =>
BlockData m (Either Address RewardAccount) ChainEvents s
-> Wallet s -> m ([FilteredBlock], (DeltaWallet s, Wallet s))
applyBlockData (NonEmpty Block
-> BlockData Identity (Either Address RewardAccount) ChainEvents s
forall (m :: * -> *) addr tx s.
NonEmpty Block -> BlockData m addr tx s
List (NonEmpty Block
 -> BlockData Identity (Either Address RewardAccount) ChainEvents s)
-> NonEmpty Block
-> BlockData Identity (Either Address RewardAccount) ChainEvents s
forall a b. (a -> b) -> a -> b
$ Block
block Block -> [Block] -> NonEmpty Block
forall a. a -> [a] -> NonEmpty a
:| [])
  where
    fromFiltered :: [FilteredBlock] -> FilteredBlock
fromFiltered [] = FilteredBlock :: Slot -> [(Tx, TxMeta)] -> [DelegationCertificate] -> FilteredBlock
FilteredBlock
        { $sel:slot:FilteredBlock :: Slot
slot = ChainPoint -> Slot
toSlot (ChainPoint -> Slot) -> ChainPoint -> Slot
forall a b. (a -> b) -> a -> b
$ BlockHeader -> ChainPoint
chainPointFromBlockHeader (Block
block Block
-> ((BlockHeader -> Const BlockHeader BlockHeader)
    -> Block -> Const BlockHeader Block)
-> BlockHeader
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "header"
  ((BlockHeader -> Const BlockHeader BlockHeader)
   -> Block -> Const BlockHeader Block)
(BlockHeader -> Const BlockHeader BlockHeader)
-> Block -> Const BlockHeader Block
#header)
        , $sel:transactions:FilteredBlock :: [(Tx, TxMeta)]
transactions = []
        , $sel:delegations:FilteredBlock :: [DelegationCertificate]
delegations = []
        }
    fromFiltered (FilteredBlock
fblock:[FilteredBlock]
_) = FilteredBlock
fblock

-- | Apply multiple blocks in sequence to an existing wallet and
-- return a list of intermediate wallet states.
--
-- If the input blocks are a 'List', then one intermediate wallet
-- state is returned for each block in the list.
-- If the input blocks are a 'Summary', then only one final wallet state
-- is returned.
--
-- More specifically, for an initial wallet state @w0@ and a 'List' of
-- of blocks
--
-- > bs = [b1, b2, …, bn]@
--
-- , the function returns
--
-- @
-- [ (filtered b1, (delta w0 -> w1 , w1 = w0 + b1))
-- , (filtered b2, (delta w1 -> w2 , w2 = w1 + b2))
-- , …
-- , (filtered bn, (delta w(n-1) -> wn, wn = w(n-1)+bn))
-- ]
--
-- Here:
--
-- * @filtered bj@ refers to the set of transactions contained in the
--   block @bj@ that were actually applied to the wallet state.
-- * @wi + bj@ refers to the wallet state obtained after applying
--   the block @bi@ to the wallet @wj@.
-- * delta wi -> wj@ refers to the delta that was applied in order
--   to obtain @wj@ from @wi@.
--
applyBlocks
    :: (IsOurs s Address, IsOurs s RewardAccount, Monad m)
    => BlockData m (Either Address RewardAccount) ChainEvents s
    -> Wallet s
    -> m (NonEmpty ([FilteredBlock], (DeltaWallet s, Wallet s)))
applyBlocks :: BlockData m (Either Address RewardAccount) ChainEvents s
-> Wallet s
-> m (NonEmpty ([FilteredBlock], (DeltaWallet s, Wallet s)))
applyBlocks (List (Block
block0 :| [Block]
blocks)) Wallet s
w0 = NonEmpty ([FilteredBlock], (DeltaWallet s, Wallet s))
-> m (NonEmpty ([FilteredBlock], (DeltaWallet s, Wallet s)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty ([FilteredBlock], (DeltaWallet s, Wallet s))
 -> m (NonEmpty ([FilteredBlock], (DeltaWallet s, Wallet s))))
-> NonEmpty ([FilteredBlock], (DeltaWallet s, Wallet s))
-> m (NonEmpty ([FilteredBlock], (DeltaWallet s, Wallet s)))
forall a b. (a -> b) -> a -> b
$
    (([FilteredBlock], (DeltaWallet s, Wallet s))
 -> Block -> ([FilteredBlock], (DeltaWallet s, Wallet s)))
-> ([FilteredBlock], (DeltaWallet s, Wallet s))
-> [Block]
-> NonEmpty ([FilteredBlock], (DeltaWallet s, Wallet s))
forall (f :: * -> *) b a.
Foldable f =>
(b -> a -> b) -> b -> f a -> NonEmpty b
NE.scanl ([FilteredBlock], (DeltaWallet s, Wallet s))
-> Block -> ([FilteredBlock], (DeltaWallet s, Wallet s))
forall s a a.
(IsOurs s Address, IsOurs s RewardAccount) =>
(a, (a, Wallet s))
-> Block -> ([FilteredBlock], (DeltaWallet s, Wallet s))
applyBlock' ((FilteredBlock -> [FilteredBlock])
-> (FilteredBlock, (DeltaWallet s, Wallet s))
-> ([FilteredBlock], (DeltaWallet s, Wallet s))
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (FilteredBlock -> [FilteredBlock] -> [FilteredBlock]
forall a. a -> [a] -> [a]
:[]) ((FilteredBlock, (DeltaWallet s, Wallet s))
 -> ([FilteredBlock], (DeltaWallet s, Wallet s)))
-> (FilteredBlock, (DeltaWallet s, Wallet s))
-> ([FilteredBlock], (DeltaWallet s, Wallet s))
forall a b. (a -> b) -> a -> b
$ Block -> Wallet s -> (FilteredBlock, (DeltaWallet s, Wallet s))
forall s.
(IsOurs s Address, IsOurs s RewardAccount) =>
Block -> Wallet s -> (FilteredBlock, (DeltaWallet s, Wallet s))
applyBlock Block
block0 Wallet s
w0) [Block]
blocks
  where
    applyBlock' :: (a, (a, Wallet s))
-> Block -> ([FilteredBlock], (DeltaWallet s, Wallet s))
applyBlock' (a
_,(a
_,Wallet s
w)) Block
block = (FilteredBlock -> [FilteredBlock])
-> (FilteredBlock, (DeltaWallet s, Wallet s))
-> ([FilteredBlock], (DeltaWallet s, Wallet s))
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (FilteredBlock -> [FilteredBlock] -> [FilteredBlock]
forall a. a -> [a] -> [a]
:[]) ((FilteredBlock, (DeltaWallet s, Wallet s))
 -> ([FilteredBlock], (DeltaWallet s, Wallet s)))
-> (FilteredBlock, (DeltaWallet s, Wallet s))
-> ([FilteredBlock], (DeltaWallet s, Wallet s))
forall a b. (a -> b) -> a -> b
$ Block -> Wallet s -> (FilteredBlock, (DeltaWallet s, Wallet s))
forall s.
(IsOurs s Address, IsOurs s RewardAccount) =>
Block -> Wallet s -> (FilteredBlock, (DeltaWallet s, Wallet s))
applyBlock Block
block Wallet s
w
applyBlocks summary :: BlockData m (Either Address RewardAccount) ChainEvents s
summary@(Summary DiscoverTxs (Either Address RewardAccount) ChainEvents s
_ BlockSummary m (Either Address RewardAccount) ChainEvents
_) Wallet s
w =
    (([FilteredBlock], (DeltaWallet s, Wallet s))
-> [([FilteredBlock], (DeltaWallet s, Wallet s))]
-> NonEmpty ([FilteredBlock], (DeltaWallet s, Wallet s))
forall a. a -> [a] -> NonEmpty a
NE.:| []) (([FilteredBlock], (DeltaWallet s, Wallet s))
 -> NonEmpty ([FilteredBlock], (DeltaWallet s, Wallet s)))
-> m ([FilteredBlock], (DeltaWallet s, Wallet s))
-> m (NonEmpty ([FilteredBlock], (DeltaWallet s, Wallet s)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockData m (Either Address RewardAccount) ChainEvents s
-> Wallet s -> m ([FilteredBlock], (DeltaWallet s, Wallet s))
forall s (m :: * -> *).
(IsOurs s Address, IsOurs s RewardAccount, Monad m) =>
BlockData m (Either Address RewardAccount) ChainEvents s
-> Wallet s -> m ([FilteredBlock], (DeltaWallet s, Wallet s))
applyBlockData BlockData m (Either Address RewardAccount) ChainEvents s
summary Wallet s
w

-- | Apply multiple blocks in sequence to an existing wallet
-- and return the final wallet state as well as the transactions
-- that were applied.
applyBlockData
    :: (IsOurs s Address, IsOurs s RewardAccount, Monad m)
    => BlockData m (Either Address RewardAccount) ChainEvents s
    -> Wallet s
    -> m ([FilteredBlock], (DeltaWallet s, Wallet s))
applyBlockData :: BlockData m (Either Address RewardAccount) ChainEvents s
-> Wallet s -> m ([FilteredBlock], (DeltaWallet s, Wallet s))
applyBlockData BlockData m (Either Address RewardAccount) ChainEvents s
blocks (Wallet !UTxO
u0 BlockHeader
_ s
s0) = do
    (ChainEvents
chainEvents, s
s1) <- BlockData m (Either Address RewardAccount) ChainEvents s
-> s -> m (ChainEvents, s)
forall s (m :: * -> *).
(IsOurs s Address, IsOurs s RewardAccount, Monad m) =>
BlockData m (Either Address RewardAccount) ChainEvents s
-> s -> m (ChainEvents, s)
discoverFromBlockData BlockData m (Either Address RewardAccount) ChainEvents s
blocks s
s0
    let blockEvents :: [BlockEvents]
blockEvents = ChainEvents -> [BlockEvents]
toAscBlockEvents ChainEvents
chainEvents
        applies :: UTxO -> BlockEvents -> ((FilteredBlock, DeltaUTxO), UTxO)
applies UTxO
u BlockEvents
blockEvent = BlockEvents -> s -> UTxO -> ((FilteredBlock, DeltaUTxO), UTxO)
forall s.
(IsOurs s Address, IsOurs s RewardAccount) =>
BlockEvents -> s -> UTxO -> ((FilteredBlock, DeltaUTxO), UTxO)
applyBlockEventsToUTxO BlockEvents
blockEvent s
s1 UTxO
u
        ([(FilteredBlock, DeltaUTxO)]
processedBlocks, UTxO
u1) = (UTxO -> BlockEvents -> ((FilteredBlock, DeltaUTxO), UTxO))
-> UTxO -> [BlockEvents] -> ([(FilteredBlock, DeltaUTxO)], UTxO)
forall s a o. (s -> a -> (o, s)) -> s -> [a] -> ([o], s)
mapAccumL' UTxO -> BlockEvents -> ((FilteredBlock, DeltaUTxO), UTxO)
applies UTxO
u0 [BlockEvents]
blockEvents
        filteredBlocks :: [FilteredBlock]
filteredBlocks = ((FilteredBlock, DeltaUTxO) -> FilteredBlock)
-> [(FilteredBlock, DeltaUTxO)] -> [FilteredBlock]
forall a b. (a -> b) -> [a] -> [b]
map (FilteredBlock, DeltaUTxO) -> FilteredBlock
forall a b. (a, b) -> a
fst [(FilteredBlock, DeltaUTxO)]
processedBlocks
        tip1 :: BlockHeader
tip1 = BlockData m (Either Address RewardAccount) ChainEvents s
-> BlockHeader
forall (m :: * -> *) addr txs s.
BlockData m addr txs s -> BlockHeader
lastHeader BlockData m (Either Address RewardAccount) ChainEvents s
blocks
        dtip :: Replace BlockHeader
dtip = BlockHeader -> Replace BlockHeader
forall a. a -> Replace a
Delta.Replace BlockHeader
tip1
        ds :: Replace s
ds = s -> Replace s
forall a. a -> Replace a
Delta.Replace s
s1
        du :: DeltaUTxO
du = [DeltaUTxO] -> DeltaUTxO
forall a. Monoid a => [a] -> a
mconcat ([DeltaUTxO] -> [DeltaUTxO]
forall a. [a] -> [a]
reverse ([DeltaUTxO] -> [DeltaUTxO]) -> [DeltaUTxO] -> [DeltaUTxO]
forall a b. (a -> b) -> a -> b
$ ((FilteredBlock, DeltaUTxO) -> DeltaUTxO)
-> [(FilteredBlock, DeltaUTxO)] -> [DeltaUTxO]
forall a b. (a -> b) -> [a] -> [b]
map (FilteredBlock, DeltaUTxO) -> DeltaUTxO
forall a b. (a, b) -> b
snd [(FilteredBlock, DeltaUTxO)]
processedBlocks)
        dw :: DeltaWallet s
dw = DeltaWallet :: forall s.
DeltaUTxO
-> Replace BlockHeader -> DeltaAddressBook s -> DeltaWallet s
DeltaWallet
            { $sel:deltaUTxO:DeltaWallet :: DeltaUTxO
deltaUTxO = DeltaUTxO
du , $sel:deltaAddressBook:DeltaWallet :: Replace s
deltaAddressBook = Replace s
ds, $sel:deltaCurrentTip:DeltaWallet :: Replace BlockHeader
deltaCurrentTip = Replace BlockHeader
dtip }
    ([FilteredBlock], (DeltaWallet s, Wallet s))
-> m ([FilteredBlock], (DeltaWallet s, Wallet s))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FilteredBlock]
filteredBlocks, (DeltaWallet s
dw, UTxO -> BlockHeader -> s -> Wallet s
forall s. UTxO -> BlockHeader -> s -> Wallet s
Wallet UTxO
u1 BlockHeader
tip1 s
s1))

-- | Strict variant of 'mapAccumL'.
mapAccumL' :: (s -> a -> (o,s)) -> s -> [a] -> ([o],s)
mapAccumL' :: (s -> a -> (o, s)) -> s -> [a] -> ([o], s)
mapAccumL' s -> a -> (o, s)
f = [o] -> s -> [a] -> ([o], s)
go []
  where
    go :: [o] -> s -> [a] -> ([o], s)
go [o]
os !s
s0 []     = ([o] -> [o]
forall a. [a] -> [a]
reverse [o]
os, s
s0)
    go [o]
os !s
s0 (a
x:[a]
xs) = case s -> a -> (o, s)
f s
s0 a
x of
        (!o
o,!s
s1) -> [o] -> s -> [a] -> ([o], s)
go (o
oo -> [o] -> [o]
forall a. a -> [a] -> [a]
:[o]
os) s
s1 [a]
xs

-- | BlockData which has been paired with discovery facilities.
data BlockData m addr tx s
    = List (NonEmpty Block)
    | Summary (DiscoverTxs addr tx s) (BlockSummary m addr tx)

-- | First 'BlockHeader' of the blocks represented
-- by 'BlockData'.
firstHeader :: BlockData m addr txs s -> BlockHeader
firstHeader :: BlockData m addr txs s -> BlockHeader
firstHeader (List NonEmpty Block
xs) = Block -> BlockHeader
header (Block -> BlockHeader) -> Block -> BlockHeader
forall a b. (a -> b) -> a -> b
$ NonEmpty Block -> Block
forall a. NonEmpty a -> a
NE.head NonEmpty Block
xs
firstHeader (Summary DiscoverTxs addr txs s
_ BlockSummary{BlockHeader
$sel:from:BlockSummary :: forall (m :: * -> *) addr txs.
BlockSummary m addr txs -> BlockHeader
from :: BlockHeader
from}) = BlockHeader
from

-- | Last 'BlockHeader' of the blocks represented
-- by 'BlockData'.
lastHeader :: BlockData m addr txs s -> BlockHeader
lastHeader :: BlockData m addr txs s -> BlockHeader
lastHeader (List NonEmpty Block
xs) = Block -> BlockHeader
header (Block -> BlockHeader) -> Block -> BlockHeader
forall a b. (a -> b) -> a -> b
$ NonEmpty Block -> Block
forall a. NonEmpty a -> a
NE.last NonEmpty Block
xs
lastHeader (Summary DiscoverTxs addr txs s
_ BlockSummary{BlockHeader
$sel:to:BlockSummary :: forall (m :: * -> *) addr txs.
BlockSummary m addr txs -> BlockHeader
to :: BlockHeader
to}) = BlockHeader
to

{-------------------------------------------------------------------------------
                                   Accessors
-------------------------------------------------------------------------------}

-- | Available balance = 'balance' . 'availableUTxO'
availableBalance :: Set Tx -> Wallet s -> TokenBundle
availableBalance :: Set Tx -> Wallet s -> TokenBundle
availableBalance Set Tx
pending =
    UTxO -> TokenBundle
balance (UTxO -> TokenBundle)
-> (Wallet s -> UTxO) -> Wallet s -> TokenBundle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Tx -> Wallet s -> UTxO
forall s. Set Tx -> Wallet s -> UTxO
availableUTxO Set Tx
pending

-- | Total balance = 'balance' . 'totalUTxO' +? rewards
totalBalance
    :: (IsOurs s Address, IsOurs s RewardAccount)
    => Set Tx
    -> Coin
    -> Wallet s
    -> TokenBundle
totalBalance :: Set Tx -> Coin -> Wallet s -> TokenBundle
totalBalance Set Tx
pending Coin
rewards wallet :: Wallet s
wallet@(Wallet UTxO
_ BlockHeader
_ s
s) =
    UTxO -> TokenBundle
balance (Set Tx -> Wallet s -> UTxO
forall s. IsOurs s Address => Set Tx -> Wallet s -> UTxO
totalUTxO Set Tx
pending Wallet s
wallet) TokenBundle -> TokenBundle -> TokenBundle
`TB.add` TokenBundle
rewardsBalance
  where
    rewardsBalance :: TokenBundle
rewardsBalance
        | Bool
hasPendingWithdrawals = TokenBundle
forall a. Monoid a => a
mempty
        | Bool
otherwise = Coin -> TokenBundle
TB.fromCoin Coin
rewards

    hasPendingWithdrawals :: Bool
hasPendingWithdrawals =
        (Tx -> Bool) -> Set Tx -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((RewardAccount -> Bool) -> [RewardAccount] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (s -> RewardAccount -> Bool
forall s addr. IsOurs s addr => s -> addr -> Bool
ours s
s) ([RewardAccount] -> Bool) -> (Tx -> [RewardAccount]) -> Tx -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map RewardAccount Coin -> [RewardAccount]
forall k a. Map k a -> [k]
Map.keys (Map RewardAccount Coin -> [RewardAccount])
-> (Tx -> Map RewardAccount Coin) -> Tx -> [RewardAccount]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx -> Map RewardAccount Coin
withdrawals) Set Tx
pending

-- | Available UTxO = @pending ⋪ utxo@
availableUTxO
    :: Set Tx
    -> Wallet s
    -> UTxO
availableUTxO :: Set Tx -> Wallet s -> UTxO
availableUTxO Set Tx
pending (Wallet UTxO
u BlockHeader
_ s
_) = UTxO
u UTxO -> Set TxIn -> UTxO
`excluding` Set TxIn
used
  where
    used :: Set TxIn
    used :: Set TxIn
used = (Tx -> Set TxIn) -> Set Tx -> Set TxIn
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap' Tx -> Set TxIn
getUsedTxIn Set Tx
pending

    -- UTxO which have been spent or committed as collateral in a pending
    -- transaction are not available to use in future transactions.
    getUsedTxIn :: Tx -> Set TxIn
    getUsedTxIn :: Tx -> Set TxIn
getUsedTxIn Tx
tx = [TxIn] -> Set TxIn
forall a. Ord a => [a] -> Set a
Set.fromList ([TxIn] -> Set TxIn) -> [TxIn] -> Set TxIn
forall a b. (a -> b) -> a -> b
$ (TxIn, Coin) -> TxIn
forall a b. (a, b) -> a
fst ((TxIn, Coin) -> TxIn) -> [(TxIn, Coin)] -> [TxIn]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[(TxIn, Coin)]] -> [(TxIn, Coin)]
forall a. Monoid a => [a] -> a
mconcat
        [ Tx
tx Tx
-> (([(TxIn, Coin)] -> Const [(TxIn, Coin)] [(TxIn, Coin)])
    -> Tx -> Const [(TxIn, Coin)] Tx)
-> [(TxIn, Coin)]
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "resolvedInputs"
  (([(TxIn, Coin)] -> Const [(TxIn, Coin)] [(TxIn, Coin)])
   -> Tx -> Const [(TxIn, Coin)] Tx)
([(TxIn, Coin)] -> Const [(TxIn, Coin)] [(TxIn, Coin)])
-> Tx -> Const [(TxIn, Coin)] Tx
#resolvedInputs
        , Tx
tx Tx
-> (([(TxIn, Coin)] -> Const [(TxIn, Coin)] [(TxIn, Coin)])
    -> Tx -> Const [(TxIn, Coin)] Tx)
-> [(TxIn, Coin)]
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "resolvedCollateralInputs"
  (([(TxIn, Coin)] -> Const [(TxIn, Coin)] [(TxIn, Coin)])
   -> Tx -> Const [(TxIn, Coin)] Tx)
([(TxIn, Coin)] -> Const [(TxIn, Coin)] [(TxIn, Coin)])
-> Tx -> Const [(TxIn, Coin)] Tx
#resolvedCollateralInputs
        ]

-- | Computes the total 'UTxO' set of a wallet.
--
-- This total 'UTxO' set is a projection of how the wallet's UTxO set would look
-- if all pending transactions were applied successfully.
--
-- >>> totalUTxO pendingTxs wallet
-- >>>     = utxo wallet
-- >>>     − inputs pendingTxs
-- >>>     ∪ change pendingTxs
--
totalUTxO
    :: IsOurs s Address
    => Set Tx
    -> Wallet s
    -> UTxO
totalUTxO :: Set Tx -> Wallet s -> UTxO
totalUTxO Set Tx
pending (Wallet UTxO
u BlockHeader
_ s
s) =
    (UTxO
u UTxO -> Set TxIn -> UTxO
`excluding` Set TxIn
spent) UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> Set Tx -> s -> UTxO
forall s. IsOurs s Address => Set Tx -> s -> UTxO
changeUTxO Set Tx
pending s
s
  where
    spent :: Set TxIn
    spent :: Set TxIn
spent = (Tx -> Set TxIn) -> Set Tx -> Set TxIn
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap' Tx -> Set TxIn
getSpentTxIn Set Tx
pending

    -- NOTE: In 'availableUTxO', we exclude UTxO committed as collateral, but
    -- not here. Since the total UTxO set is indented to be a projection of how
    -- the UTxO set would look if all pending transactions are applied
    -- successfully: if a transaction is applied successfully, then its
    -- collateral inputs cannot be consumed.
    getSpentTxIn :: Tx -> Set TxIn
    getSpentTxIn :: Tx -> Set TxIn
getSpentTxIn Tx
tx = [TxIn] -> Set TxIn
forall a. Ord a => [a] -> Set a
Set.fromList ([TxIn] -> Set TxIn) -> [TxIn] -> Set TxIn
forall a b. (a -> b) -> a -> b
$ (TxIn, Coin) -> TxIn
forall a b. (a, b) -> a
fst ((TxIn, Coin) -> TxIn) -> [(TxIn, Coin)] -> [TxIn]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tx
tx Tx
-> (([(TxIn, Coin)] -> Const [(TxIn, Coin)] [(TxIn, Coin)])
    -> Tx -> Const [(TxIn, Coin)] Tx)
-> [(TxIn, Coin)]
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "resolvedInputs"
  (([(TxIn, Coin)] -> Const [(TxIn, Coin)] [(TxIn, Coin)])
   -> Tx -> Const [(TxIn, Coin)] Tx)
([(TxIn, Coin)] -> Const [(TxIn, Coin)] [(TxIn, Coin)])
-> Tx -> Const [(TxIn, Coin)] Tx
#resolvedInputs

-- | Retrieve the change 'UTxO' contained in a set of pending transactions.
--
-- We perform /some/ address discovery within the list of pending addresses,
-- but we do not store the result.
-- Instead, we essentially assume that the address discovery state @s@ contains
-- enough information to collect the change addresses in the pending
-- transactions.
--
-- Caveats:
-- * Rollbacks can invalidate this assumption. 🙈
-- * The order of pending transactions is based on transaction hashes,
--   and typically does not agree with the order in which we have submitted
--   them onto the chain. Hence, the address discovery phase is not really
--   very effective.
--   TODO: Add slot to 'Tx' and sort the pending set by slot.
changeUTxO
    :: IsOurs s Address
    => Set Tx
    -> s
    -> UTxO
changeUTxO :: Set Tx -> s -> UTxO
changeUTxO Set Tx
pending = State s UTxO -> s -> UTxO
forall s a. State s a -> s -> a
evalState (State s UTxO -> s -> UTxO) -> State s UTxO -> s -> UTxO
forall a b. (a -> b) -> a -> b
$
    [UTxO] -> UTxO
forall a. Monoid a => [a] -> a
mconcat ([UTxO] -> UTxO) -> StateT s Identity [UTxO] -> State s UTxO
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Tx -> State s UTxO) -> [Tx] -> StateT s Identity [UTxO]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
        ((Address -> StateT s Identity Bool) -> UTxO -> State s UTxO
forall (f :: * -> *).
Monad f =>
(Address -> f Bool) -> UTxO -> f UTxO
UTxO.filterByAddressM Address -> StateT s Identity Bool
forall s addr. IsOurs s addr => addr -> State s Bool
isOursState (UTxO -> State s UTxO) -> (Tx -> UTxO) -> Tx -> State s UTxO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx -> UTxO
utxoFromTx)
        (Set Tx -> [Tx]
forall a. Set a -> [a]
Set.toList Set Tx
pending)

{-------------------------------------------------------------------------------
                                UTxO operations
-------------------------------------------------------------------------------}

-- | Applies a transaction to a UTxO, moving it from one state to another.
--
-- When applying a transaction to a UTxO:
--   1. We need to remove any unspents that have been spent in the transaction.
--   2. Add any unspents that we've received via the transaction.
--      In this function, we assume that all outputs belong to us.
--
-- Properties:
--
-- @
-- balance (applyTxToUTxO tx u) = balance u
--                              + balance (utxoFromTx tx)
--                              - balance (u `restrictedBy` inputs tx)
-- unUTxO (applyTxToUTxO tx u) = unUTxO u
--     `Map.union` unUTxO (utxoFromTx tx)
--     `Map.difference` unUTxO (u `restrictedBy` inputs tx)
-- applyTxToUTxO tx u = spend tx u <> utxoFromTx tx
-- applyTxToUTxO tx u = spend tx (u <> utxoFromTx tx)
-- @
applyTxToUTxO
    :: Tx
    -> UTxO
    -> UTxO
applyTxToUTxO :: Tx -> UTxO -> UTxO
applyTxToUTxO Tx
tx !UTxO
u = Tx -> UTxO -> UTxO
spendTx Tx
tx UTxO
u UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> Tx -> UTxO
utxoFromTx Tx
tx

-- | Remove unspent outputs that are consumed by the given transaction.
--
-- @
-- spendTx tx u `isSubsetOf` u
-- balance (spendTx tx u) <= balance u
-- balance (spendTx tx u) = balance u - balance (u `restrictedBy` inputs tx)
-- spendTx tx u = u `excluding` inputs tx
-- spendTx tx (filterByAddress f u) = filterByAddress f (spendTx tx u)
-- spendTx tx (u <> utxoFromTx tx) = spendTx tx u <> utxoFromTx tx
-- @
spendTx :: Tx -> UTxO -> UTxO
spendTx :: Tx -> UTxO -> UTxO
spendTx Tx
tx = (DeltaUTxO, UTxO) -> UTxO
forall a b. (a, b) -> b
snd ((DeltaUTxO, UTxO) -> UTxO)
-> (UTxO -> (DeltaUTxO, UTxO)) -> UTxO -> UTxO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx -> UTxO -> (DeltaUTxO, UTxO)
spendTxD Tx
tx

-- | Remove unspent outputs that are consumed by the given transaction.
spendTxD :: Tx -> UTxO -> (DeltaUTxO, UTxO)
spendTxD :: Tx -> UTxO -> (DeltaUTxO, UTxO)
spendTxD Tx
tx !UTxO
u =
    UTxO
u UTxO -> Set TxIn -> (DeltaUTxO, UTxO)
`excludingD` [TxIn] -> Set TxIn
forall a. Ord a => [a] -> Set a
Set.fromList [TxIn]
inputsToExclude
  where
    inputsToExclude :: [TxIn]
inputsToExclude =
        if Tx -> Bool
txScriptInvalid Tx
tx
        then Tx -> [TxIn]
collateralInputs Tx
tx
        else Tx -> [TxIn]
inputs Tx
tx

-- | Generates a UTxO set from a transaction.
--
-- The generated UTxO set corresponds to the value provided by the transaction.
--
-- It is important for transaction outputs to be ordered correctly, as their
-- indices within this ordering will determine how they are referenced as
-- transaction inputs in subsequent blocks.
--
-- Assuming the transaction is not marked as having an invalid script, the
-- following properties should hold:
--
-- prop> balance (utxoFromTx tx) == foldMap tokens (outputs tx)
-- prop> size    (utxoFromTx tx) == length         (outputs tx)
-- prop> toList  (utxoFromTx tx) == toList         (outputs tx)
--
-- However, if the transaction is marked as having an invalid script, then the
-- following properties should hold:
--
-- prop> balance (utxoFromTx tx) == foldMap tokens (collateralOutput tx)
-- prop> size    (utxoFromTx tx) == length         (collateralOutput tx)
-- prop> toList  (utxoFromTx tx) == toList         (collateralOutput tx)
--
utxoFromTx :: Tx -> UTxO
utxoFromTx :: Tx -> UTxO
utxoFromTx Tx
tx =
    if Tx -> Bool
txScriptInvalid Tx
tx
    then Tx -> UTxO
utxoFromTxCollateralOutputs Tx
tx
    else Tx -> UTxO
utxoFromTxOutputs Tx
tx

-- | Generates a UTxO set from the ordinary outputs of a transaction.
--
-- This function ignores the transaction's script validity.
--
utxoFromTxOutputs :: Tx -> UTxO
utxoFromTxOutputs :: Tx -> UTxO
utxoFromTxOutputs Tx {Hash "Tx"
$sel:txId:Tx :: Tx -> Hash "Tx"
txId :: Hash "Tx"
txId, [TxOut]
$sel:outputs:Tx :: Tx -> [TxOut]
outputs :: [TxOut]
outputs} =
    Map TxIn TxOut -> UTxO
UTxO (Map TxIn TxOut -> UTxO) -> Map TxIn TxOut -> UTxO
forall a b. (a -> b) -> a -> b
$ [(TxIn, TxOut)] -> Map TxIn TxOut
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(TxIn, TxOut)] -> Map TxIn TxOut)
-> [(TxIn, TxOut)] -> Map TxIn TxOut
forall a b. (a -> b) -> a -> b
$ [TxIn] -> [TxOut] -> [(TxIn, TxOut)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Hash "Tx" -> Word32 -> TxIn
TxIn Hash "Tx"
txId (Word32 -> TxIn) -> [Word32] -> [TxIn]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Word32
0..]) [TxOut]
outputs

-- | Generates a UTxO set from the collateral outputs of a transaction.
--
-- This function ignores the transaction's script validity.
--
utxoFromTxCollateralOutputs :: Tx -> UTxO
utxoFromTxCollateralOutputs :: Tx -> UTxO
utxoFromTxCollateralOutputs Tx {Hash "Tx"
txId :: Hash "Tx"
$sel:txId:Tx :: Tx -> Hash "Tx"
txId, [TxOut]
outputs :: [TxOut]
$sel:outputs:Tx :: Tx -> [TxOut]
outputs, Maybe TxOut
$sel:collateralOutput:Tx :: Tx -> Maybe TxOut
collateralOutput :: Maybe TxOut
collateralOutput} =
    Map TxIn TxOut -> UTxO
UTxO (Map TxIn TxOut -> UTxO) -> Map TxIn TxOut -> UTxO
forall a b. (a -> b) -> a -> b
$ [(TxIn, TxOut)] -> Map TxIn TxOut
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(TxIn, TxOut)] -> Map TxIn TxOut)
-> [(TxIn, TxOut)] -> Map TxIn TxOut
forall a b. (a -> b) -> a -> b
$ Maybe (TxIn, TxOut) -> [(TxIn, TxOut)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Maybe (TxIn, TxOut) -> [(TxIn, TxOut)])
-> Maybe (TxIn, TxOut) -> [(TxIn, TxOut)]
forall a b. (a -> b) -> a -> b
$ (Hash "Tx" -> Word32 -> TxIn
TxIn Hash "Tx"
txId Word32
index,) (TxOut -> (TxIn, TxOut)) -> Maybe TxOut -> Maybe (TxIn, TxOut)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe TxOut
collateralOutput
  where
    -- To reference a collateral output within transaction t, we specify an
    -- output index that is equal to the number of ordinary outputs within t.
    --
    -- See definition of function "collOuts" within "Formal Specification of
    -- the Cardano Ledger for the Babbage era".
    --
    -- https://hydra.iohk.io/build/14336206/download/1/babbage-changes.pdf
    --
    index :: Word32
    index :: Word32
index = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([TxOut] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TxOut]
outputs)

{-------------------------------------------------------------------------------
                        Address ownership and discovery
-------------------------------------------------------------------------------}

-- | Perform address discovery on a 'Block' by going through all transactions
-- and delegation certificates in the block.
discoverAddressesBlock
    :: (IsOurs s Address, IsOurs s RewardAccount)
    => Block -> s -> (DeltaAddressBook s, s)
discoverAddressesBlock :: Block -> s -> (DeltaAddressBook s, s)
discoverAddressesBlock Block
block s
s0 = (s -> DeltaAddressBook s
forall a. a -> Replace a
Delta.Replace s
s2, s
s2)
  where
    -- NOTE: Order in which we perform discovery is important.
    s1 :: s
s1 = (s -> DelegationCertificate -> s)
-> s -> [DelegationCertificate] -> s
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' s -> DelegationCertificate -> s
forall s. IsOurs s RewardAccount => s -> DelegationCertificate -> s
discoverCert s
s0 (Block
block Block
-> (([DelegationCertificate]
     -> Const [DelegationCertificate] [DelegationCertificate])
    -> Block -> Const [DelegationCertificate] Block)
-> [DelegationCertificate]
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "delegations"
  (([DelegationCertificate]
    -> Const [DelegationCertificate] [DelegationCertificate])
   -> Block -> Const [DelegationCertificate] Block)
([DelegationCertificate]
 -> Const [DelegationCertificate] [DelegationCertificate])
-> Block -> Const [DelegationCertificate] Block
#delegations)
    s2 :: s
s2 = (s -> Tx -> s) -> s -> [Tx] -> s
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' s -> Tx -> s
forall (t :: * -> *) b addr a s s a.
(Foldable t, IsOurs b addr, IsOurs b a, HasField' "address" s a,
 HasField' "outputs" s (t s),
 HasField' "withdrawals" s (Map addr a)) =>
b -> s -> b
discoverTx   s
s1 (Block
block Block
-> (([Tx] -> Const [Tx] [Tx]) -> Block -> Const [Tx] Block) -> [Tx]
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "transactions"
  (([Tx] -> Const [Tx] [Tx]) -> Block -> Const [Tx] Block)
([Tx] -> Const [Tx] [Tx]) -> Block -> Const [Tx] Block
#transactions)

    discoverCert :: s -> DelegationCertificate -> s
discoverCert s
s DelegationCertificate
cert = s -> RewardAccount -> s
forall s addr. IsOurs s addr => s -> addr -> s
updateOurs s
s (DelegationCertificate -> RewardAccount
dlgCertAccount DelegationCertificate
cert)

    -- NOTE: Only outputs and withdrawals can potentially
    -- result in the extension of the address pool and
    -- the learning of new addresses.
    --
    -- Inputs and collateral are forced to use existing addresses.
    discoverTx :: b -> s -> b
discoverTx b
s s
tx = b -> s -> b
forall b addr s a.
(IsOurs b addr, HasField' "withdrawals" s (Map addr a)) =>
b -> s -> b
discoverWithdrawals (b -> s -> b
forall (t :: * -> *) s a s s.
(Foldable t, IsOurs s a, HasField' "address" s a,
 HasField' "outputs" s (t s)) =>
s -> s -> s
discoverOutputs b
s s
tx) s
tx
    discoverOutputs :: s -> s -> s
discoverOutputs s
s s
tx =
        (s -> s -> s) -> s -> t s -> s
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' (\s
s_ s
out -> s -> a -> s
forall s addr. IsOurs s addr => s -> addr -> s
updateOurs s
s_ (s
out s -> ((a -> Const a a) -> s -> Const a s) -> a
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel "address" ((a -> Const a a) -> s -> Const a s)
(a -> Const a a) -> s -> Const a s
#address)) s
s (s
tx s -> ((t s -> Const (t s) (t s)) -> s -> Const (t s) s) -> t s
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "outputs" ((t s -> Const (t s) (t s)) -> s -> Const (t s) s)
(t s -> Const (t s) (t s)) -> s -> Const (t s) s
#outputs)
    discoverWithdrawals :: b -> s -> b
discoverWithdrawals b
s s
tx =
        (b -> addr -> b) -> b -> [addr] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' b -> addr -> b
forall s addr. IsOurs s addr => s -> addr -> s
updateOurs b
s ([addr] -> b) -> [addr] -> b
forall a b. (a -> b) -> a -> b
$ Map addr a -> [addr]
forall k a. Map k a -> [k]
Map.keys (s
tx s
-> ((Map addr a -> Const (Map addr a) (Map addr a))
    -> s -> Const (Map addr a) s)
-> Map addr a
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "withdrawals"
  ((Map addr a -> Const (Map addr a) (Map addr a))
   -> s -> Const (Map addr a) s)
(Map addr a -> Const (Map addr a) (Map addr a))
-> s -> Const (Map addr a) s
#withdrawals)

-- | Perform address and transaction discovery on 'BlockData',
discoverFromBlockData
    :: (IsOurs s Address, IsOurs s RewardAccount, Monad m)
    => BlockData m (Either Address RewardAccount) ChainEvents s
    -> s
    -> m (ChainEvents, s)
discoverFromBlockData :: BlockData m (Either Address RewardAccount) ChainEvents s
-> s -> m (ChainEvents, s)
discoverFromBlockData (List NonEmpty Block
blocks) !s
s0 =
    (ChainEvents, s) -> m (ChainEvents, s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([BlockEvents] -> ChainEvents
fromBlockEvents ([BlockEvents] -> ChainEvents)
-> ([Block] -> [BlockEvents]) -> [Block] -> ChainEvents
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Block -> BlockEvents) -> [Block] -> [BlockEvents]
forall a b. (a -> b) -> [a] -> [b]
map Block -> BlockEvents
fromEntireBlock ([Block] -> ChainEvents) -> [Block] -> ChainEvents
forall a b. (a -> b) -> a -> b
$ NonEmpty Block -> [Block]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Block
blocks , s
s1)
  where
    s1 :: s
s1 = (s -> Block -> s) -> s -> [Block] -> s
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' (\s
s Block
bl -> (DeltaAddressBook s, s) -> s
forall a b. (a, b) -> b
snd ((DeltaAddressBook s, s) -> s) -> (DeltaAddressBook s, s) -> s
forall a b. (a -> b) -> a -> b
$ Block -> s -> (DeltaAddressBook s, s)
forall s.
(IsOurs s Address, IsOurs s RewardAccount) =>
Block -> s -> (DeltaAddressBook s, s)
discoverAddressesBlock Block
bl s
s) s
s0 ([Block] -> s) -> [Block] -> s
forall a b. (a -> b) -> a -> b
$ NonEmpty Block -> [Block]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Block
blocks
discoverFromBlockData (Summary DiscoverTxs (Either Address RewardAccount) ChainEvents s
dis BlockSummary m (Either Address RewardAccount) ChainEvents
summary) !s
s0 =
    DiscoverTxs (Either Address RewardAccount) ChainEvents s
-> (Either Address RewardAccount -> m ChainEvents)
-> s
-> m (ChainEvents, s)
forall addr txs s.
DiscoverTxs addr txs s
-> forall (m :: * -> *).
   Monad m =>
   (addr -> m txs) -> s -> m (txs, s)
discoverTxs DiscoverTxs (Either Address RewardAccount) ChainEvents s
dis (BlockSummary m (Either Address RewardAccount) ChainEvents
summary BlockSummary m (Either Address RewardAccount) ChainEvents
-> (((Either Address RewardAccount -> m ChainEvents)
     -> Const
          (Either Address RewardAccount -> m ChainEvents)
          (Either Address RewardAccount -> m ChainEvents))
    -> BlockSummary m (Either Address RewardAccount) ChainEvents
    -> Const
         (Either Address RewardAccount -> m ChainEvents)
         (BlockSummary m (Either Address RewardAccount) ChainEvents))
-> Either Address RewardAccount
-> m ChainEvents
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "query"
  (((Either Address RewardAccount -> m ChainEvents)
    -> Const
         (Either Address RewardAccount -> m ChainEvents)
         (Either Address RewardAccount -> m ChainEvents))
   -> BlockSummary m (Either Address RewardAccount) ChainEvents
   -> Const
        (Either Address RewardAccount -> m ChainEvents)
        (BlockSummary m (Either Address RewardAccount) ChainEvents))
((Either Address RewardAccount -> m ChainEvents)
 -> Const
      (Either Address RewardAccount -> m ChainEvents)
      (Either Address RewardAccount -> m ChainEvents))
-> BlockSummary m (Either Address RewardAccount) ChainEvents
-> Const
     (Either Address RewardAccount -> m ChainEvents)
     (BlockSummary m (Either Address RewardAccount) ChainEvents)
#query) s
s0

-- | Indicates whether an address is known to be ours, without updating the
-- address discovery state.
ours :: IsOurs s addr => s -> addr -> Bool
ours :: s -> addr -> Bool
ours s
s addr
x = Maybe (NonEmpty DerivationIndex) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (NonEmpty DerivationIndex) -> Bool)
-> ((Maybe (NonEmpty DerivationIndex), s)
    -> Maybe (NonEmpty DerivationIndex))
-> (Maybe (NonEmpty DerivationIndex), s)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (NonEmpty DerivationIndex), s)
-> Maybe (NonEmpty DerivationIndex)
forall a b. (a, b) -> a
fst ((Maybe (NonEmpty DerivationIndex), s) -> Bool)
-> (Maybe (NonEmpty DerivationIndex), s) -> Bool
forall a b. (a -> b) -> a -> b
$ addr -> s -> (Maybe (NonEmpty DerivationIndex), s)
forall s entity.
IsOurs s entity =>
entity -> s -> (Maybe (NonEmpty DerivationIndex), s)
isOurs addr
x s
s

-- | Add an address to the address discovery state, iff it belongs to us.
updateOurs :: IsOurs s addr => s -> addr -> s
updateOurs :: s -> addr -> s
updateOurs s
s addr
x = (Maybe (NonEmpty DerivationIndex), s) -> s
forall a b. (a, b) -> b
snd ((Maybe (NonEmpty DerivationIndex), s) -> s)
-> (Maybe (NonEmpty DerivationIndex), s) -> s
forall a b. (a -> b) -> a -> b
$ addr -> s -> (Maybe (NonEmpty DerivationIndex), s)
forall s entity.
IsOurs s entity =>
entity -> s -> (Maybe (NonEmpty DerivationIndex), s)
isOurs addr
x s
s

-- | Perform stateful address discovery, and return whether the given address
-- belongs to us.
isOursState :: IsOurs s addr => addr -> State s Bool
isOursState :: addr -> State s Bool
isOursState addr
x = Maybe (NonEmpty DerivationIndex) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (NonEmpty DerivationIndex) -> Bool)
-> StateT s Identity (Maybe (NonEmpty DerivationIndex))
-> State s Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (s -> (Maybe (NonEmpty DerivationIndex), s))
-> StateT s Identity (Maybe (NonEmpty DerivationIndex))
forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state (addr -> s -> (Maybe (NonEmpty DerivationIndex), s)
forall s entity.
IsOurs s entity =>
entity -> s -> (Maybe (NonEmpty DerivationIndex), s)
isOurs addr
x)

{-------------------------------------------------------------------------------
                              Modification of UTxO
-------------------------------------------------------------------------------}

-- | Apply a 'Block' to the 'UTxO'.
--
-- Here, we assume that address discovery has already been performed and
-- that the address discovery state @s@ identifies all our output addresses
-- in the given 'Block'.
--
-- A 'FilteredBlock' is returned in addition to the new 'UTxO' set.
-- This 'FilteredBlock' includes those transactions and delegations
-- that are in the given 'Block' and that are also relevant to the wallet,
-- i.e. they have
--
-- * Outputs with known addresses
-- * Inputs referring to known outputs of previous transactions.
--
-- In practice, most transactions that are relevant to the wallet
-- have at least one output that belongs to the wallet:
-- either because we have received funds from another party,
-- or because the wallet has created a change output when sending
-- funds to another party.
-- But some transactions may actually have no relevant outputs whatsoever
-- and be only linked to the wallet by their inputs.
--
-- As inputs are given as references to outputs (no address, no coin value),
-- we have to traverse all transactions in the block in order to
-- discover the outputs that belong to us and be able to infer that the
-- corresponding inputs belong to us as well.
applyBlockEventsToUTxO
    :: (IsOurs s Address, IsOurs s RewardAccount)
    => BlockEvents
    -> s
    -> UTxO
    -> ((FilteredBlock, DeltaUTxO), UTxO)
applyBlockEventsToUTxO :: BlockEvents -> s -> UTxO -> ((FilteredBlock, DeltaUTxO), UTxO)
applyBlockEventsToUTxO BlockEvents{Slot
$sel:slot:BlockEvents :: BlockEvents -> Slot
slot :: Slot
slot,Quantity "block" Word32
$sel:blockHeight:BlockEvents :: BlockEvents -> Quantity "block" Word32
blockHeight :: Quantity "block" Word32
blockHeight,Sublist Tx
$sel:transactions:BlockEvents :: BlockEvents -> Sublist Tx
transactions :: Sublist Tx
transactions,Sublist DelegationCertificate
$sel:delegations:BlockEvents :: BlockEvents -> Sublist DelegationCertificate
delegations :: Sublist DelegationCertificate
delegations} s
s UTxO
u0 =
    ((FilteredBlock
fblock, DeltaUTxO
du1), UTxO
u1)
  where
    fblock :: FilteredBlock
fblock = FilteredBlock :: Slot -> [(Tx, TxMeta)] -> [DelegationCertificate] -> FilteredBlock
FilteredBlock
      { Slot
slot :: Slot
$sel:slot:FilteredBlock :: Slot
slot
      , $sel:transactions:FilteredBlock :: [(Tx, TxMeta)]
transactions = [(Tx, TxMeta)] -> [(Tx, TxMeta)]
forall a. [a] -> [a]
reverse [(Tx, TxMeta)]
rtxs1
      , $sel:delegations:FilteredBlock :: [DelegationCertificate]
delegations = (DelegationCertificate -> Bool)
-> [DelegationCertificate] -> [DelegationCertificate]
forall a. (a -> Bool) -> [a] -> [a]
filter (s -> RewardAccount -> Bool
forall s addr. IsOurs s addr => s -> addr -> Bool
ours s
s (RewardAccount -> Bool)
-> (DelegationCertificate -> RewardAccount)
-> DelegationCertificate
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DelegationCertificate -> RewardAccount
dlgCertAccount) ([DelegationCertificate] -> [DelegationCertificate])
-> [DelegationCertificate] -> [DelegationCertificate]
forall a b. (a -> b) -> a -> b
$ Sublist DelegationCertificate -> [DelegationCertificate]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Sublist DelegationCertificate
delegations
      }
    ([(Tx, TxMeta)]
rtxs1, DeltaUTxO
du1, UTxO
u1) = (([(Tx, TxMeta)], DeltaUTxO, UTxO)
 -> Tx -> ([(Tx, TxMeta)], DeltaUTxO, UTxO))
-> ([(Tx, TxMeta)], DeltaUTxO, UTxO)
-> [Tx]
-> ([(Tx, TxMeta)], DeltaUTxO, UTxO)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' ([(Tx, TxMeta)], DeltaUTxO, UTxO)
-> Tx -> ([(Tx, TxMeta)], DeltaUTxO, UTxO)
applyOurTx ([(Tx, TxMeta)]
forall a. Monoid a => a
mempty, DeltaUTxO
forall a. Monoid a => a
mempty, UTxO
u0)
        ([Tx] -> ([(Tx, TxMeta)], DeltaUTxO, UTxO))
-> [Tx] -> ([(Tx, TxMeta)], DeltaUTxO, UTxO)
forall a b. (a -> b) -> a -> b
$ Sublist Tx -> [Tx]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Sublist Tx
transactions

    applyOurTx
        :: ([(Tx, TxMeta)], DeltaUTxO, UTxO)
        -> Tx
        -> ([(Tx, TxMeta)], DeltaUTxO, UTxO)
    applyOurTx :: ([(Tx, TxMeta)], DeltaUTxO, UTxO)
-> Tx -> ([(Tx, TxMeta)], DeltaUTxO, UTxO)
applyOurTx (![(Tx, TxMeta)]
txs, !DeltaUTxO
du, !UTxO
u) !Tx
tx =
        case Slot
-> Quantity "block" Word32
-> s
-> Tx
-> UTxO
-> Maybe ((Tx, TxMeta), DeltaUTxO, UTxO)
forall s.
(IsOurs s Address, IsOurs s RewardAccount) =>
Slot
-> Quantity "block" Word32
-> s
-> Tx
-> UTxO
-> Maybe ((Tx, TxMeta), DeltaUTxO, UTxO)
applyOurTxToUTxO Slot
slot Quantity "block" Word32
blockHeight s
s Tx
tx UTxO
u of
            Maybe ((Tx, TxMeta), DeltaUTxO, UTxO)
Nothing -> ([(Tx, TxMeta)]
txs, DeltaUTxO
du, UTxO
u)
            Just ((Tx, TxMeta)
tx', DeltaUTxO
du', UTxO
u') -> ((Tx, TxMeta)
tx' (Tx, TxMeta) -> [(Tx, TxMeta)] -> [(Tx, TxMeta)]
forall a. a -> [a] -> [a]
: [(Tx, TxMeta)]
txs, DeltaUTxO
du' DeltaUTxO -> DeltaUTxO -> DeltaUTxO
forall a. Semigroup a => a -> a -> a
<> DeltaUTxO
du, UTxO
u')

-- | Apply the given transaction to the 'UTxO'.
-- Return 'Just' if and only if the transaction is relevant to the wallet
-- (changes the 'UTxO' set or makes a withdrawal).
--
-- It satisfies the following property:
--
-- > isJust (applyOurTxToUTxO slot bh state1 tx u) = b
-- >   where (b, state1) = runState (isOurTx tx u) state0
applyOurTxToUTxO
    :: (IsOurs s Address, IsOurs s RewardAccount)
    => Slot
    -> Quantity "block" Word32
    -> s
    -> Tx
    -> UTxO
    -> Maybe ((Tx, TxMeta), DeltaUTxO, UTxO)
applyOurTxToUTxO :: Slot
-> Quantity "block" Word32
-> s
-> Tx
-> UTxO
-> Maybe ((Tx, TxMeta), DeltaUTxO, UTxO)
applyOurTxToUTxO !Slot
slot !Quantity "block" Word32
blockHeight !s
s !Tx
tx !UTxO
u0 =
    if Bool
hasKnownWithdrawal Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
isUnchangedUTxO
        then ((Tx, TxMeta), DeltaUTxO, UTxO)
-> Maybe ((Tx, TxMeta), DeltaUTxO, UTxO)
forall a. a -> Maybe a
Just ((Tx
tx {$sel:fee:Tx :: Maybe Coin
fee = Direction -> Maybe Coin
actualFee Direction
dir}, TxMeta
txmeta), DeltaUTxO
du, UTxO
u)
        else Maybe ((Tx, TxMeta), DeltaUTxO, UTxO)
forall a. Maybe a
Nothing
  where
    -- The next UTxO state (apply a state transition) (e.g. remove
    -- transaction outputs we've spent)
    (DeltaUTxO
du, UTxO
u) = (DeltaUTxO
du21 DeltaUTxO -> DeltaUTxO -> DeltaUTxO
forall a. Semigroup a => a -> a -> a
<> DeltaUTxO
du10, UTxO
u2)

    -- Note [Naming of Deltas]
    -- The identifiers for delta encodings carry two indices
    -- which indicate the "to" and "from" value of the delta.
    -- For example, the delta du10 maps the value u0 to the value u1,
    -- and the delta du21 maps the value u1 to the value u2.
    -- In general, the naming convention is  ui = duij `apply` uj
    (DeltaUTxO
du10, UTxO
u1)   = Tx -> UTxO -> (DeltaUTxO, UTxO)
spendTxD Tx
tx UTxO
u0
    receivedUTxO :: UTxO
receivedUTxO = (Address -> Bool) -> UTxO -> UTxO
UTxO.filterByAddress (s -> Address -> Bool
forall s addr. IsOurs s addr => s -> addr -> Bool
ours s
s) (Tx -> UTxO
utxoFromTx Tx
tx)
    (DeltaUTxO
du21, UTxO
u2)   = UTxO -> UTxO -> (DeltaUTxO, UTxO)
receiveD UTxO
u1 UTxO
receivedUTxO

    -- NOTE: Performance.
    -- This function is part of a tight loop that inspects all transactions
    -- (> 30M Txs as of Feb 2022).
    -- Thus, we make a small performance optimization here.
    -- Specifically, we want to reject a transaction as soon as possible
    -- if it does not change the 'UTxO' set. The test
    isUnchangedUTxO :: Bool
isUnchangedUTxO = UTxO -> Bool
UTxO.null UTxO
receivedUTxO Bool -> Bool -> Bool
&& DeltaUTxO
forall a. Monoid a => a
mempty DeltaUTxO -> DeltaUTxO -> Bool
forall a. Eq a => a -> a -> Bool
== DeltaUTxO
du10
    -- allocates slightly fewer new Set/Map than the definition
    --   isUnchangedUTxO =  mempty == du

    ourWithdrawalSum :: Coin
ourWithdrawalSum = s -> Tx -> Coin
forall s. IsOurs s RewardAccount => s -> Tx -> Coin
ourWithdrawalSumFromTx s
s Tx
tx

    -- Balance of the UTxO that we received and that we spent
    received :: TokenBundle
received = UTxO -> TokenBundle
balance UTxO
receivedUTxO
    spent :: TokenBundle
spent = UTxO -> TokenBundle
balance (UTxO
u0 UTxO -> Set TxIn -> UTxO
`UTxO.restrictedBy` DeltaUTxO -> Set TxIn
UTxO.excluded DeltaUTxO
du10)
        TokenBundle -> TokenBundle -> TokenBundle
`TB.add` Coin -> TokenBundle
TB.fromCoin Coin
ourWithdrawalSum

    adaSpent :: Coin
adaSpent = TokenBundle -> Coin
TB.getCoin TokenBundle
spent
    adaReceived :: Coin
adaReceived = TokenBundle -> Coin
TB.getCoin TokenBundle
received
    dir :: Direction
dir = if Coin
adaSpent Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
> Coin
adaReceived then Direction
Outgoing else Direction
Incoming
    amount :: Coin
amount = Coin -> Coin -> Coin
distance Coin
adaSpent Coin
adaReceived

    -- Transaction metadata computed from the above information
    txmeta :: TxMeta
txmeta = TxMeta :: TxStatus
-> Direction
-> SlotNo
-> Quantity "block" Word32
-> Coin
-> Maybe SlotNo
-> TxMeta
TxMeta
        { $sel:status:TxMeta :: TxStatus
status = TxStatus
InLedger
        , $sel:direction:TxMeta :: Direction
direction = Direction
dir
        , $sel:slotNo:TxMeta :: SlotNo
slotNo = Slot -> SlotNo
forall p. Num p => WithOrigin p -> p
pseudoSlotNo Slot
slot
        , Quantity "block" Word32
$sel:blockHeight:TxMeta :: Quantity "block" Word32
blockHeight :: Quantity "block" Word32
blockHeight
        , $sel:amount:TxMeta :: Coin
amount = Coin
amount
        , $sel:expiry:TxMeta :: Maybe SlotNo
expiry = Maybe SlotNo
forall a. Maybe a
Nothing
        }
      where
        pseudoSlotNo :: WithOrigin p -> p
pseudoSlotNo WithOrigin p
Origin = p
0
        pseudoSlotNo (At p
sl) = p
sl

    hasKnownWithdrawal :: Bool
hasKnownWithdrawal = Coin
ourWithdrawalSum Coin -> Coin -> Bool
forall a. Eq a => a -> a -> Bool
/= Coin
forall a. Monoid a => a
mempty

    -- NOTE 1: The only case where fees can be 'Nothing' is when dealing with
    -- a Byron transaction. In which case fees can actually be calculated as
    -- the delta between inputs and outputs.
    --
    -- NOTE 2: We do not have in practice the actual input amounts, yet we
    -- do make the assumption that if one input is ours, then all inputs are
    -- necessarily ours and therefore, known as part of our current UTxO.
    actualFee :: Direction -> Maybe Coin
actualFee Direction
direction = case (Tx
tx Tx
-> ((Maybe Coin -> Const (Maybe Coin) (Maybe Coin))
    -> Tx -> Const (Maybe Coin) Tx)
-> Maybe Coin
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "fee"
  ((Maybe Coin -> Const (Maybe Coin) (Maybe Coin))
   -> Tx -> Const (Maybe Coin) Tx)
(Maybe Coin -> Const (Maybe Coin) (Maybe Coin))
-> Tx -> Const (Maybe Coin) Tx
#fee, Direction
direction) of
        (Just Coin
x, Direction
Outgoing) ->
            -- Shelley and beyond:
            Coin -> Maybe Coin
forall a. a -> Maybe a
Just Coin
x
        (Maybe Coin
Nothing, Direction
Outgoing) ->
            -- Byron:
            let totalOut :: Coin
totalOut = [Coin] -> Coin
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
F.fold (TxOut -> Coin
txOutCoin (TxOut -> Coin) -> [TxOut] -> [Coin]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tx -> [TxOut]
outputs Tx
tx)
                totalIn :: Coin
totalIn = TokenBundle -> Coin
TB.getCoin TokenBundle
spent
            in
            Coin -> Maybe Coin
forall a. a -> Maybe a
Just (Coin -> Maybe Coin) -> Coin -> Maybe Coin
forall a b. (a -> b) -> a -> b
$ Coin -> Coin -> Coin
distance Coin
totalIn Coin
totalOut
        (Maybe Coin
_, Direction
Incoming) ->
            Maybe Coin
forall a. Maybe a
Nothing

ourWithdrawalSumFromTx
    :: IsOurs s RewardAccount
    => s -> Tx -> Coin
ourWithdrawalSumFromTx :: s -> Tx -> Coin
ourWithdrawalSumFromTx s
s Tx
tx
    -- If a transaction has failed script validation, then the ledger rules
    -- require that applying the transaction shall have no effect other than
    -- to fully spend the collateral inputs included within that transaction.
    --
    -- Therefore, any reward withdrawals included in such a transaction should
    -- also have no effect.
    --
    | Tx -> Bool
txScriptInvalid Tx
tx = Natural -> Coin
Coin Natural
0
    | Bool
otherwise = (Coin -> RewardAccount -> Coin -> Coin)
-> Coin -> Map RewardAccount Coin -> Coin
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' Coin -> RewardAccount -> Coin -> Coin
add (Natural -> Coin
Coin Natural
0) (Tx
tx Tx
-> ((Map RewardAccount Coin
     -> Const (Map RewardAccount Coin) (Map RewardAccount Coin))
    -> Tx -> Const (Map RewardAccount Coin) Tx)
-> Map RewardAccount Coin
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "withdrawals"
  ((Map RewardAccount Coin
    -> Const (Map RewardAccount Coin) (Map RewardAccount Coin))
   -> Tx -> Const (Map RewardAccount Coin) Tx)
(Map RewardAccount Coin
 -> Const (Map RewardAccount Coin) (Map RewardAccount Coin))
-> Tx -> Const (Map RewardAccount Coin) Tx
#withdrawals)
  where
    add :: Coin -> RewardAccount -> Coin -> Coin
add Coin
total RewardAccount
account Coin
coin
        | s -> RewardAccount -> Bool
forall s addr. IsOurs s addr => s -> addr -> Bool
ours s
s RewardAccount
account = Coin
total Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
coin
        | Bool
otherwise      = Coin
total