{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

-- |
-- Copyright: © 2018-2020 IOHK
-- License: Apache-2.0
--
-- Provides wallet layer functions that are used by API layer. Uses both
-- "Cardano.Wallet.DB" and "Cardano.Wallet.Network" to realize its role as
-- being intermediary between the three.
--
-- Functions of the wallet layer are often parameterized with variables
-- following the convention below:
--
-- - @s@: A __s__tate used to keep track of known addresses. Typically, possible
--   values for this parameter are described in 'Cardano.Wallet.AddressDiscovery' sub-modules.
--   For instance @SeqState@ or @Rnd State@.
--
-- - @k@: A __k__ey derivation scheme intrinsically connected to the underlying discovery
--   state @s@. This describes how the hierarchical structure of a wallet is
--   defined as well as the relationship between secret keys and public
--   addresses.

module Cardano.Wallet
    (
    -- * Development
    -- $Development

    -- * WalletLayer
        WalletLayer (..)

    -- * Capabilities
    -- $Capabilities
    , HasDBLayer
    , dbLayer
    , HasLogger
    , logger
    , HasNetworkLayer
    , networkLayer
    , HasTransactionLayer
    , transactionLayer
    , HasGenesisData
    , genesisData

    -- * Interface
    -- ** Wallet
    , createWallet
    , createIcarusWallet
    , attachPrivateKeyFromPwd
    , attachPrivateKeyFromPwdHash
    , getWalletUtxoSnapshot
    , listUtxoStatistics
    , readWallet
    , deleteWallet
    , restoreWallet
    , updateWallet
    , updateWalletPassphraseWithOldPassphrase
    , updateWalletPassphraseWithMnemonic
    , walletSyncProgress
    , fetchRewardBalance
    , manageRewardBalance
    , rollbackBlocks
    , checkWalletIntegrity
    , readNextWithdrawal
    , readRewardAccount
    , someRewardAccount
    , readPolicyPublicKey
    , writePolicyPublicKey
    , queryRewardBalance
    , ErrWalletAlreadyExists (..)
    , ErrNoSuchWallet (..)
    , ErrListUTxOStatistics (..)
    , ErrUpdatePassphrase (..)
    , ErrFetchRewards (..)
    , ErrCheckWalletIntegrity (..)
    , ErrWalletNotResponding (..)
    , ErrReadRewardAccount (..)
    , ErrReadPolicyPublicKey (..)
    , ErrWritePolicyPublicKey (..)
    , ErrGetPolicyId (..)

    -- * Shared Wallet
    , updateCosigner
    , ErrAddCosignerKey (..)
    , ErrConstructSharedWallet (..)
    , normalizeSharedAddress
    , constructSharedTransaction

    -- ** Address
    , createRandomAddress
    , importRandomAddresses
    , listAddresses
    , normalizeDelegationAddress
    , lookupTxIns
    , lookupTxOuts
    , ErrCreateRandomAddress(..)
    , ErrImportRandomAddress(..)
    , ErrImportAddress(..)
    , ErrDecodeTx (..)

    -- ** Payment
    , getTxExpiry
    , SelectAssetsParams (..)
    , selectAssets
    , readWalletUTxOIndex
    , assignChangeAddresses
    , assignChangeAddressesAndUpdateDb
    , assignChangeAddressesWithoutDbUpdate
    , selectionToUnsignedTx
    , buildAndSignTransaction
    , signTransaction
    , constructTransaction
    , constructTxMeta
    , ErrSelectAssets(..)
    , ErrSignPayment (..)
    , ErrNotASequentialWallet (..)
    , ErrWithdrawalNotWorth (..)
    , ErrConstructTx (..)
    , ErrMintBurnAssets (..)
    , ErrBalanceTx (..)
    , ErrBalanceTxInternalError (..)
    , ErrUpdateSealedTx (..)
    , ErrCannotJoin (..)
    , ErrCannotQuit (..)
    , ErrSubmitTransaction (..)

    -- ** Migration
    , createMigrationPlan
    , migrationPlanToSelectionWithdrawals
    , SelectionWithoutChange
    , ErrCreateMigrationPlan (..)

    -- ** Delegation
    , PoolRetirementEpochInfo (..)
    , joinStakePool
    , quitStakePool
    , guardJoin
    , guardQuit
    , ErrStakePoolDelegation (..)

    -- ** Fee Estimation
    , FeeEstimation (..)
    , estimateFee
    , calcMinimumDeposit
    , calcMinimumCoinValues

    -- ** Transaction
    , forgetTx
    , listTransactions
    , listAssets
    , getTransaction
    , submitExternalTx
    , submitTx
    , balanceTransaction
    , PartialTx (..)
    , LocalTxSubmissionConfig (..)
    , defaultLocalTxSubmissionConfig
    , runLocalTxSubmissionPool
    , ErrMkTransaction (..)
    , ErrSubmitTx (..)
    , ErrRemoveTx (..)
    , ErrPostTx (..)
    , ErrListTransactions (..)
    , ErrGetTransaction (..)
    , ErrNoSuchTransaction (..)
    , ErrStartTimeLaterThanEndTime (..)
    , ErrWitnessTx (..)

    -- ** Root Key
    , withRootKey
    , derivePublicKey
    , getAccountPublicKeyAtIndex
    , readAccountPublicKey
    , signMetadataWith
    , ErrWithRootKey (..)
    , ErrWrongPassphrase (..)
    , ErrSignMetadataWith (..)
    , ErrDerivePublicKey(..)
    , ErrReadAccountPublicKey(..)
    , ErrInvalidDerivationIndex(..)

    -- * Utilities
    , throttle
    , guardHardIndex
    , withNoSuchWallet
    , posAndNegFromCardanoValue

    -- * Logging
    , WalletWorkerLog (..)
    , WalletFollowLog (..)
    , WalletLog (..)
    , TxSubmitLog (..)
    ) where

import Prelude hiding
    ( log )

import Cardano.Address.Derivation
    ( XPrv, XPub )
import Cardano.Address.Script
    ( Cosigner (..), KeyHash )
import Cardano.Address.Style.Shared
    ( deriveDelegationPublicKey )
import Cardano.Api
    ( serialiseToCBOR )
import Cardano.BM.Data.Severity
    ( Severity (..) )
import Cardano.BM.Data.Tracer
    ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) )
import Cardano.Crypto.Wallet
    ( toXPub )
import Cardano.Slotting.Slot
    ( SlotNo (..) )
import Cardano.Wallet.Address.Book
    ( AddressBookIso, Prologue (..), getPrologue )
import Cardano.Wallet.Checkpoints
    ( DeltaCheckpoints (..)
    , SparseCheckpointsConfig (..)
    , defaultSparseCheckpointsConfig
    , sparseCheckpoints
    )
import Cardano.Wallet.CoinSelection
    ( Selection
    , SelectionBalanceError (..)
    , SelectionCollateralRequirement (..)
    , SelectionConstraints (..)
    , SelectionError (..)
    , SelectionOf (..)
    , SelectionOutputError (..)
    , SelectionParams (..)
    , SelectionReportDetailed
    , SelectionReportSummarized
    , SelectionSkeleton (..)
    , SelectionStrategy (..)
    , UnableToConstructChangeError (..)
    , WalletSelectionContext
    , WalletUTxO (..)
    , emptySkeleton
    , makeSelectionReportDetailed
    , makeSelectionReportSummarized
    , performSelection
    )
import Cardano.Wallet.CoinSelection.Internal.Balance
    ( SelectionLimitOf (NoLimit) )
import Cardano.Wallet.DB
    ( DBLayer (..)
    , ErrNoSuchTransaction (..)
    , ErrPutLocalTxSubmission (..)
    , ErrRemoveTx (..)
    , ErrWalletAlreadyExists (..)
    )
import Cardano.Wallet.DB.WalletState
    ( DeltaWalletState1 (..)
    , ErrNoSuchWallet (..)
    , adjustNoSuchWallet
    , fromWallet
    , getLatest
    , getSlot
    )
import Cardano.Wallet.Logging
    ( BracketLog
    , BracketLog' (..)
    , bracketTracer
    , formatResultMsg
    , resultSeverity
    , traceResult
    , unliftIOTracer
    )
import Cardano.Wallet.Network
    ( ChainFollowLog (..)
    , ChainFollower (..)
    , ErrPostTx (..)
    , NetworkLayer (..)
    )
import Cardano.Wallet.Primitive.AddressDerivation
    ( BoundedAddressLength (..)
    , DelegationAddress (..)
    , Depth (..)
    , DerivationIndex (..)
    , DerivationPrefix (..)
    , DerivationType (..)
    , HardDerivation (..)
    , Index (..)
    , MkKeyFingerprint (..)
    , NetworkDiscriminant (..)
    , PaymentAddress (..)
    , Role (..)
    , SoftDerivation (..)
    , ToRewardAccount (..)
    , WalletKey (..)
    , deriveRewardAccount
    , hashVerificationKey
    , liftIndex
    , stakeDerivationPath
    )
import Cardano.Wallet.Primitive.AddressDerivation.Byron
    ( ByronKey )
import Cardano.Wallet.Primitive.AddressDerivation.Icarus
    ( IcarusKey )
import Cardano.Wallet.Primitive.AddressDerivation.MintBurn
    ( derivePolicyPrivateKey, policyDerivationPath )
import Cardano.Wallet.Primitive.AddressDerivation.SharedKey
    ( SharedKey (..) )
import Cardano.Wallet.Primitive.AddressDerivation.Shelley
    ( ShelleyKey, deriveAccountPrivateKeyShelley )
import Cardano.Wallet.Primitive.AddressDiscovery
    ( CompareDiscovery (..)
    , GenChange (..)
    , GetAccount (..)
    , GetPurpose (..)
    , IsOurs (..)
    , IsOwned (..)
    , KnownAddresses (..)
    , MaybeLight (..)
    )
import Cardano.Wallet.Primitive.AddressDiscovery.Random
    ( ErrImportAddress (..), RndStateLike )
import Cardano.Wallet.Primitive.AddressDiscovery.Sequential
    ( SeqState, defaultAddressPoolGap, mkSeqStateFromRootXPrv, purposeBIP44 )
import Cardano.Wallet.Primitive.AddressDiscovery.Shared
    ( CredentialType (..)
    , ErrAddCosigner (..)
    , ErrScriptTemplate (..)
    , SharedState (..)
    , addCosignerAccXPub
    )
import Cardano.Wallet.Primitive.BlockSummary
    ( ChainEvents )
import Cardano.Wallet.Primitive.Migration
    ( MigrationPlan (..) )
import Cardano.Wallet.Primitive.Model
    ( BlockData (..)
    , Wallet
    , applyBlocks
    , availableUTxO
    , currentTip
    , firstHeader
    , getState
    , initWallet
    , totalUTxO
    )
import Cardano.Wallet.Primitive.Passphrase
    ( ErrWrongPassphrase (..)
    , Passphrase
    , PassphraseHash
    , PassphraseScheme (..)
    , WalletPassphraseInfo (..)
    , checkPassphrase
    , currentPassphraseScheme
    , encryptPassphrase'
    , preparePassphrase
    )
import Cardano.Wallet.Primitive.Slotting
    ( PastHorizonException (..)
    , TimeInterpreter
    , addRelTime
    , ceilingSlotAt
    , currentRelativeTime
    , interpretQuery
    , neverFails
    , slotRangeFromTimeRange
    , slotToUTCTime
    , unsafeExtendSafeZone
    )
import Cardano.Wallet.Primitive.SyncProgress
    ( SyncProgress )
import Cardano.Wallet.Primitive.Types
    ( ActiveSlotCoefficient (..)
    , Block (..)
    , BlockHeader (..)
    , ChainPoint (..)
    , DelegationCertificate (..)
    , FeePolicy (LinearFee)
    , GenesisParameters (..)
    , IsDelegatingTo (..)
    , LinearFunction (LinearFunction)
    , NetworkParameters (..)
    , PoolId (..)
    , PoolLifeCycleStatus (..)
    , ProtocolParameters (..)
    , Range (..)
    , Signature (..)
    , Slot
    , SlottingParameters (..)
    , SortOrder (..)
    , WalletDelegation (..)
    , WalletDelegationStatus (..)
    , WalletId (..)
    , WalletMetadata (..)
    , WalletName (..)
    , WithOrigin (..)
    , dlgCertPoolId
    , toSlot
    , wholeRange
    )
import Cardano.Wallet.Primitive.Types.Address
    ( Address (..), AddressState (..) )
import Cardano.Wallet.Primitive.Types.Coin
    ( Coin (..) )
import Cardano.Wallet.Primitive.Types.Hash
    ( Hash (..) )
import Cardano.Wallet.Primitive.Types.Redeemer
    ( Redeemer (..) )
import Cardano.Wallet.Primitive.Types.RewardAccount
    ( RewardAccount (..) )
import Cardano.Wallet.Primitive.Types.TokenBundle
    ( TokenBundle (..) )
import Cardano.Wallet.Primitive.Types.TokenPolicy
    ( TokenName (UnsafeTokenName), TokenPolicyId (UnsafeTokenPolicyId) )
import Cardano.Wallet.Primitive.Types.TokenQuantity
    ( TokenQuantity (TokenQuantity) )
import Cardano.Wallet.Primitive.Types.Tx
    ( Direction (..)
    , LocalTxSubmissionStatus
    , SealedTx (..)
    , TransactionInfo (..)
    , Tx (..)
    , TxChange (..)
    , TxIn (..)
    , TxMeta (..)
    , TxMetadata (..)
    , TxOut (..)
    , TxSize (..)
    , TxStatus (..)
    , UnsignedTx (..)
    , fromTransactionInfo
    , sealedTxFromCardano
    , txOutCoin
    , withdrawals
    )
import Cardano.Wallet.Primitive.Types.UTxO
    ( UTxO (..), UTxOStatistics, computeUtxoStatistics, log10 )
import Cardano.Wallet.Primitive.Types.UTxOIndex
    ( UTxOIndex )
import Cardano.Wallet.Primitive.Types.UTxOSelection
    ( UTxOSelection )
import Cardano.Wallet.Transaction
    ( DelegationAction (..)
    , ErrAssignRedeemers
    , ErrCannotJoin (..)
    , ErrCannotQuit (..)
    , ErrMkTransaction (..)
    , ErrMoreSurplusNeeded (ErrMoreSurplusNeeded)
    , ErrSignTx (..)
    , ErrUpdateSealedTx (..)
    , TransactionCtx (..)
    , TransactionLayer (..)
    , TxFeeAndChange (TxFeeAndChange)
    , TxFeeUpdate (..)
    , TxUpdate (..)
    , Withdrawal (..)
    , defaultTransactionCtx
    , withdrawalToCoin
    )
import Control.Applicative
    ( (<|>) )
import Control.Arrow
    ( first, left )
import Control.DeepSeq
    ( NFData )
import Control.Monad
    ( forM, forM_, replicateM, unless, when )
import Control.Monad.Class.MonadTime
    ( DiffTime
    , MonadMonotonicTime (..)
    , MonadTime (..)
    , Time
    , diffTime
    , getCurrentTime
    )
import Control.Monad.IO.Unlift
    ( MonadIO (..), MonadUnliftIO )
import Control.Monad.Random.Class
    ( MonadRandom (..) )
import Control.Monad.Random.Extra
    ( StdGenSeed (..), stdGenFromSeed, stdGenSeed )
import Control.Monad.Random.Strict
    ( evalRand )
import Control.Monad.Trans.Class
    ( lift )
import Control.Monad.Trans.Except
    ( ExceptT (..)
    , catchE
    , except
    , mapExceptT
    , runExceptT
    , throwE
    , withExceptT
    )
import Control.Monad.Trans.Maybe
    ( MaybeT (..), maybeToExceptT )
import Control.Monad.Trans.State
    ( evalState, runState, state )
import Control.Tracer
    ( Tracer, contramap, traceWith )
import Crypto.Hash
    ( Blake2b_256, hash )
import Data.ByteString
    ( ByteString )
import Data.DBVar
    ( modifyDBMaybe )
import Data.Either
    ( partitionEithers )
import Data.Either.Extra
    ( eitherToMaybe )
import Data.Foldable
    ( fold )
import Data.Function
    ( (&) )
import Data.Functor
    ( ($>) )
import Data.Generics.Internal.VL.Lens
    ( Lens', view, (.~), (^.) )
import Data.Generics.Labels
    ()
import Data.Generics.Product.Typed
    ( HasType, typed )
import Data.IntCast
    ( intCast, intCastMaybe )
import Data.Kind
    ( Type )
import Data.List
    ( foldl' )
import Data.List.NonEmpty
    ( NonEmpty (..) )
import Data.Map.Strict
    ( Map )
import Data.Maybe
    ( fromMaybe, isJust, mapMaybe )
import Data.Proxy
    ( Proxy (..) )
import Data.Quantity
    ( Quantity (..) )
import Data.Set
    ( Set )
import Data.Text
    ( Text )
import Data.Text.Class
    ( ToText (..) )
import Data.Time.Clock
    ( NominalDiffTime, UTCTime )
import Data.Type.Equality
    ( (:~:) (..), testEquality )
import Data.Void
    ( Void )
import Data.Word
    ( Word16, Word64 )
import Fmt
    ( Buildable
    , Builder
    , blockListF
    , blockMapF
    , build
    , listF'
    , nameF
    , pretty
    , unlinesF
    , (+|)
    , (+||)
    , (|+)
    , (||+)
    )
import GHC.Generics
    ( Generic )
import Numeric.Natural
    ( Natural )
import Safe
    ( lastMay )
import Statistics.Quantile
    ( medianUnbiased, quantiles )
import Text.Pretty.Simple
    ( pShow )
import Type.Reflection
    ( Typeable, typeRep )
import UnliftIO.Exception
    ( Exception, catch, throwIO )
import UnliftIO.MVar
    ( modifyMVar_, newMVar )

import qualified Cardano.Address.Script as CA
import qualified Cardano.Address.Style.Shared as CA
import qualified Cardano.Api as Cardano
import qualified Cardano.Api.Shelley as Cardano
import qualified Cardano.Crypto.Wallet as CC
import qualified Cardano.Wallet.Checkpoints.Policy as CP
import qualified Cardano.Wallet.CoinSelection as CS
import qualified Cardano.Wallet.Primitive.AddressDiscovery.Random as Rnd
import qualified Cardano.Wallet.Primitive.AddressDiscovery.Sequential as Seq
import qualified Cardano.Wallet.Primitive.AddressDiscovery.Shared as Shared
import qualified Cardano.Wallet.Primitive.Migration as Migration
import qualified Cardano.Wallet.Primitive.Types as W
import qualified Cardano.Wallet.Primitive.Types.Coin as Coin
import qualified Cardano.Wallet.Primitive.Types.TokenBundle as TokenBundle
import qualified Cardano.Wallet.Primitive.Types.TokenMap as TokenMap
import qualified Cardano.Wallet.Primitive.Types.UTxO as UTxO
import qualified Cardano.Wallet.Primitive.Types.UTxOIndex as UTxOIndex
import qualified Cardano.Wallet.Primitive.Types.UTxOSelection as UTxOSelection
import qualified Data.ByteArray as BA
import qualified Data.Foldable as F
import qualified Data.List as L
import qualified Data.List.NonEmpty as NE
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Vector as V

-- $Development
-- __Naming Conventions__
--
-- Components inside a particular context `ctx` can be called via dedicated
-- lenses (see Cardano.Wallet#Capabilities). These components are extracted from the context
-- in a @where@ clause according to the following naming convention:
--
-- - @db = ctx ^. dbLayer \@s \\@k@ for the 'DBLayer'.
-- - @tr = ctx ^. logger@ for the Logger.
-- - @nw = ctx ^. networkLayer@ for the 'NetworkLayer'.
-- - @tl = ctx ^. transactionLayer \\@k@ for the 'TransactionLayer'.
-- - @re = ctx ^. workerRegistry@ for the 'WorkerRegistry'.
--
-- __TroubleShooting__
--
-- @
-- • Overlapping instances for HasType (DBLayer IO s k) ctx
--     arising from a use of ‘myFunction’
--   Matching instances:
-- @
--
-- Occurs when a particular function is missing a top-level constraint
-- (because it uses another function that demands such constraint). Here,
-- `myFunction` needs its surrounding context `ctx` to have a `DBLayer` but
-- the constraint is missing from its host function.
--
-- __Fix__: Add "@HasDBLayer s k@" as a class-constraint to the surrounding function.
--
-- @
-- • Overlapping instances for HasType (DBLayer IO s t0 k0) ctx
--     arising from a use of ‘myFunction’
--   Matching givens (or their superclasses):
-- @
--
-- Occurs when a function is called in a context where type-level parameters
-- can be inferred. Here, `myFunction` is called but it is unclear
-- whether the parameter `t0` and `k0` of its context are the same as the ones
-- from the function at the call-site.
--
-- __Fix__: Add type-applications at the call-site "@myFunction \@ctx \@s \\@k@"

data WalletLayer m s (k :: Depth -> Type -> Type)
    = WalletLayer
        (Tracer m WalletWorkerLog)
        (Block, NetworkParameters)
        (NetworkLayer m Block)
        (TransactionLayer k SealedTx)
        (DBLayer m s k)
    deriving ((forall x. WalletLayer m s k -> Rep (WalletLayer m s k) x)
-> (forall x. Rep (WalletLayer m s k) x -> WalletLayer m s k)
-> Generic (WalletLayer m s k)
forall x. Rep (WalletLayer m s k) x -> WalletLayer m s k
forall x. WalletLayer m s k -> Rep (WalletLayer m s k) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (m :: * -> *) s (k :: Depth -> * -> *) x.
Rep (WalletLayer m s k) x -> WalletLayer m s k
forall (m :: * -> *) s (k :: Depth -> * -> *) x.
WalletLayer m s k -> Rep (WalletLayer m s k) x
$cto :: forall (m :: * -> *) s (k :: Depth -> * -> *) x.
Rep (WalletLayer m s k) x -> WalletLayer m s k
$cfrom :: forall (m :: * -> *) s (k :: Depth -> * -> *) x.
WalletLayer m s k -> Rep (WalletLayer m s k) x
Generic)

{-------------------------------------------------------------------------------
                                 Capabilities
-------------------------------------------------------------------------------}

-- $Capabilities
-- Each function in the wallet layer is defined in function of a non-specialized
-- context `ctx`. That context may require some extra capabilities via
-- class-constraints in the function signature. Capabilities are expressed in the
-- form of a "@HasXXX@" class-constraints sometimes with extra type parameters.
--
-- For example:
--
-- @
-- listWallets
--     :: forall ctx s k.
--         ( HasDBLayer s k ctx
--         )
--     => ctx
--     -> IO [WalletId]
-- @
--
-- Requires that the given context has an access to a database layer 'DBLayer'
-- parameterized over the wallet state, a network target and a key derivation
-- scheme. Components are pulled from the context generically (i.e. the concrete
-- `ctx` must derive 'Generic') using their associated type. The concrete `ctx`
-- is therefore expected to be a product-type of all the necessary components.
--
-- One can build an interface using only a subset of the wallet layer
-- capabilities and functions, for instance, something to fiddle with wallets
-- and their metadata does not require any networking layer.
type HasDBLayer m s k = HasType (DBLayer m s k)

type HasGenesisData = HasType (Block, NetworkParameters)

type HasLogger m msg = HasType (Tracer m msg)

-- | This module is only interested in one block-, and tx-type. This constraint
-- hides that choice, for some ease of use.
type HasNetworkLayer m = HasType (NetworkLayer m Block)

type HasTransactionLayer k = HasType (TransactionLayer k SealedTx)

dbLayer
    :: forall m s k ctx. HasDBLayer m s k ctx
    => Lens' ctx (DBLayer m s k)
dbLayer :: Lens' ctx (DBLayer m s k)
dbLayer =
    forall s.
HasType (DBLayer m s k) s =>
Lens s s (DBLayer m s k) (DBLayer m s k)
forall a s. HasType a s => Lens s s a a
typed @(DBLayer m s k)

genesisData
    :: forall ctx. HasGenesisData ctx
    => Lens' ctx (Block, NetworkParameters)
genesisData :: Lens' ctx (Block, NetworkParameters)
genesisData =
    forall s.
HasType (Block, NetworkParameters) s =>
Lens s s (Block, NetworkParameters) (Block, NetworkParameters)
forall a s. HasType a s => Lens s s a a
typed @(Block, NetworkParameters)

logger
    :: forall m msg ctx. HasLogger m msg ctx
    => Lens' ctx (Tracer m msg)
logger :: Lens' ctx (Tracer m msg)
logger =
    forall s.
HasType (Tracer m msg) s =>
Lens s s (Tracer m msg) (Tracer m msg)
forall a s. HasType a s => Lens s s a a
typed @(Tracer m msg)

networkLayer
    :: forall m ctx. (HasNetworkLayer m ctx)
    => Lens' ctx (NetworkLayer m Block)
networkLayer :: Lens' ctx (NetworkLayer m Block)
networkLayer =
    forall s.
HasType (NetworkLayer m Block) s =>
Lens s s (NetworkLayer m Block) (NetworkLayer m Block)
forall a s. HasType a s => Lens s s a a
typed @(NetworkLayer m Block)

transactionLayer
    :: forall k ctx. (HasTransactionLayer k ctx)
    => Lens' ctx (TransactionLayer k SealedTx)
transactionLayer :: Lens' ctx (TransactionLayer k SealedTx)
transactionLayer =
    forall s.
HasType (TransactionLayer k SealedTx) s =>
Lens
  s s (TransactionLayer k SealedTx) (TransactionLayer k SealedTx)
forall a s. HasType a s => Lens s s a a
typed @(TransactionLayer k SealedTx)

{-------------------------------------------------------------------------------
                                   Wallet
-------------------------------------------------------------------------------}

-- | Initialise and store a new wallet, returning its ID.
createWallet
    :: forall ctx m s k.
        ( MonadUnliftIO m
        , MonadTime m
        , HasGenesisData ctx
        , HasDBLayer m s k ctx
        , IsOurs s Address
        , IsOurs s RewardAccount
        )
    => ctx
    -> WalletId
    -> WalletName
    -> s
    -> ExceptT ErrWalletAlreadyExists m WalletId
createWallet :: ctx
-> WalletId
-> WalletName
-> s
-> ExceptT ErrWalletAlreadyExists m WalletId
createWallet ctx
ctx WalletId
wid WalletName
wname s
s = DBLayer m s k
db DBLayer m s k
-> (DBLayer m s k -> ExceptT ErrWalletAlreadyExists m WalletId)
-> ExceptT ErrWalletAlreadyExists m WalletId
forall a b. a -> (a -> b) -> b
& \DBLayer{stm [WalletId]
DBVar stm (DeltaMap WalletId (DeltaWalletState s))
WalletId -> stm [LocalTxSubmissionStatus SealedTx]
WalletId -> stm [ChainPoint]
WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
WalletId -> stm (Maybe GenesisParameters)
WalletId -> stm (Maybe WalletMetadata)
WalletId -> stm (Maybe (Wallet s))
WalletId -> stm Coin
WalletId -> ExceptT ErrNoSuchWallet stm Bool
WalletId -> ExceptT ErrNoSuchWallet stm ()
WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
forall a. stm a -> m a
atomically :: ()
prune :: ()
rollbackTo :: ()
readGenesisParameters :: ()
readPrivateKey :: ()
putPrivateKey :: ()
removePendingOrExpiredTx :: ()
updatePendingTxForExpiry :: ()
readLocalTxSubmissionPending :: ()
putLocalTxSubmission :: ()
getTx :: ()
readTxHistory :: ()
putTxHistory :: ()
readDelegationRewardBalance :: ()
putDelegationRewardBalance :: ()
putDelegationCertificate :: ()
isStakeKeyRegistered :: ()
readWalletMeta :: ()
putWalletMeta :: ()
listCheckpoints :: ()
readCheckpoint :: ()
putCheckpoint :: ()
walletsDB :: ()
listWallets :: ()
removeWallet :: ()
initializeWallet :: ()
atomically :: forall a. stm a -> m a
prune :: WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
rollbackTo :: WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
readGenesisParameters :: WalletId -> stm (Maybe GenesisParameters)
readPrivateKey :: WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
putPrivateKey :: WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
removePendingOrExpiredTx :: WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
updatePendingTxForExpiry :: WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
readLocalTxSubmissionPending :: WalletId -> stm [LocalTxSubmissionStatus SealedTx]
putLocalTxSubmission :: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
getTx :: WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
readTxHistory :: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
putTxHistory :: WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
readDelegationRewardBalance :: WalletId -> stm Coin
putDelegationRewardBalance :: WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
putDelegationCertificate :: WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
isStakeKeyRegistered :: WalletId -> ExceptT ErrNoSuchWallet stm Bool
readWalletMeta :: WalletId -> stm (Maybe WalletMetadata)
putWalletMeta :: WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
listCheckpoints :: WalletId -> stm [ChainPoint]
readCheckpoint :: WalletId -> stm (Maybe (Wallet s))
putCheckpoint :: WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
walletsDB :: DBVar stm (DeltaMap WalletId (DeltaWalletState s))
listWallets :: stm [WalletId]
removeWallet :: WalletId -> ExceptT ErrNoSuchWallet stm ()
initializeWallet :: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
..} -> do
    let ([(Tx, TxMeta)]
hist, Wallet s
cp) = Block -> s -> ([(Tx, TxMeta)], Wallet s)
forall s.
(IsOurs s Address, IsOurs s RewardAccount) =>
Block -> s -> ([(Tx, TxMeta)], Wallet s)
initWallet Block
block0 s
s
    UTCTime
now <- m UTCTime -> ExceptT ErrWalletAlreadyExists m UTCTime
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
    let meta :: WalletMetadata
meta = WalletMetadata :: WalletName
-> UTCTime
-> Maybe WalletPassphraseInfo
-> WalletDelegation
-> WalletMetadata
WalletMetadata
            { $sel:name:WalletMetadata :: WalletName
name = WalletName
wname
            , $sel:creationTime:WalletMetadata :: UTCTime
creationTime = UTCTime
now
            , $sel:passphraseInfo:WalletMetadata :: Maybe WalletPassphraseInfo
passphraseInfo = Maybe WalletPassphraseInfo
forall a. Maybe a
Nothing
            , $sel:delegation:WalletMetadata :: WalletDelegation
delegation = WalletDelegationStatus
-> [WalletDelegationNext] -> WalletDelegation
WalletDelegation WalletDelegationStatus
NotDelegating []
            }
    (stm (Either ErrWalletAlreadyExists WalletId)
 -> m (Either ErrWalletAlreadyExists WalletId))
-> ExceptT ErrWalletAlreadyExists stm WalletId
-> ExceptT ErrWalletAlreadyExists m WalletId
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT stm (Either ErrWalletAlreadyExists WalletId)
-> m (Either ErrWalletAlreadyExists WalletId)
forall a. stm a -> m a
atomically (ExceptT ErrWalletAlreadyExists stm WalletId
 -> ExceptT ErrWalletAlreadyExists m WalletId)
-> ExceptT ErrWalletAlreadyExists stm WalletId
-> ExceptT ErrWalletAlreadyExists m WalletId
forall a b. (a -> b) -> a -> b
$
        WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
initializeWallet WalletId
wid Wallet s
cp WalletMetadata
meta [(Tx, TxMeta)]
hist GenesisParameters
gp ExceptT ErrWalletAlreadyExists stm ()
-> WalletId -> ExceptT ErrWalletAlreadyExists stm WalletId
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> WalletId
wid
  where
    db :: DBLayer m s k
db = ctx
ctx ctx
-> ((DBLayer m s k -> Const (DBLayer m s k) (DBLayer m s k))
    -> ctx -> Const (DBLayer m s k) ctx)
-> DBLayer m s k
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx. HasDBLayer m s k ctx => Lens' ctx (DBLayer m s k)
forall (m :: * -> *) s (k :: Depth -> * -> *) ctx.
HasDBLayer m s k ctx =>
Lens' ctx (DBLayer m s k)
dbLayer @m @s @k
    (Block
block0, NetworkParameters GenesisParameters
gp SlottingParameters
_sp ProtocolParameters
_pp) = ctx
ctx ctx
-> (((Block, NetworkParameters)
     -> Const (Block, NetworkParameters) (Block, NetworkParameters))
    -> ctx -> Const (Block, NetworkParameters) ctx)
-> (Block, NetworkParameters)
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. ((Block, NetworkParameters)
 -> Const (Block, NetworkParameters) (Block, NetworkParameters))
-> ctx -> Const (Block, NetworkParameters) ctx
forall s.
HasType (Block, NetworkParameters) s =>
Lens s s (Block, NetworkParameters) (Block, NetworkParameters)
genesisData

-- | Initialise and store a new legacy Icarus wallet. These wallets are
-- intrinsically sequential, but, in the incentivized testnet, we only have
-- access to the a snapshot of the MainNet.
--
-- To work-around this, we scan the genesis block with an arbitrary big gap and
-- resort to a default gap afterwards.
createIcarusWallet
    :: forall ctx s k n.
        ( HasGenesisData ctx
        , HasDBLayer IO s k ctx
        , PaymentAddress n k
        , k ~ IcarusKey
        , s ~ SeqState n k
        , Typeable n
        )
    => ctx
    -> WalletId
    -> WalletName
    -> (k 'RootK XPrv, Passphrase "encryption")
    -> ExceptT ErrWalletAlreadyExists IO WalletId
createIcarusWallet :: ctx
-> WalletId
-> WalletName
-> (k 'RootK XPrv, Passphrase "encryption")
-> ExceptT ErrWalletAlreadyExists IO WalletId
createIcarusWallet ctx
ctx WalletId
wid WalletName
wname (k 'RootK XPrv, Passphrase "encryption")
credentials = DBLayer IO s k
db DBLayer IO s k
-> (DBLayer IO s k -> ExceptT ErrWalletAlreadyExists IO WalletId)
-> ExceptT ErrWalletAlreadyExists IO WalletId
forall a b. a -> (a -> b) -> b
& \DBLayer{stm [WalletId]
DBVar stm (DeltaMap WalletId (DeltaWalletState s))
WalletId -> stm [LocalTxSubmissionStatus SealedTx]
WalletId -> stm [ChainPoint]
WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
WalletId -> stm (Maybe GenesisParameters)
WalletId -> stm (Maybe WalletMetadata)
WalletId -> stm (Maybe (Wallet s))
WalletId -> stm Coin
WalletId -> ExceptT ErrNoSuchWallet stm Bool
WalletId -> ExceptT ErrNoSuchWallet stm ()
WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
forall a. stm a -> IO a
atomically :: forall a. stm a -> IO a
prune :: WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
rollbackTo :: WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
readGenesisParameters :: WalletId -> stm (Maybe GenesisParameters)
readPrivateKey :: WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
putPrivateKey :: WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
removePendingOrExpiredTx :: WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
updatePendingTxForExpiry :: WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
readLocalTxSubmissionPending :: WalletId -> stm [LocalTxSubmissionStatus SealedTx]
putLocalTxSubmission :: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
getTx :: WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
readTxHistory :: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
putTxHistory :: WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
readDelegationRewardBalance :: WalletId -> stm Coin
putDelegationRewardBalance :: WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
putDelegationCertificate :: WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
isStakeKeyRegistered :: WalletId -> ExceptT ErrNoSuchWallet stm Bool
readWalletMeta :: WalletId -> stm (Maybe WalletMetadata)
putWalletMeta :: WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
listCheckpoints :: WalletId -> stm [ChainPoint]
readCheckpoint :: WalletId -> stm (Maybe (Wallet s))
putCheckpoint :: WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
walletsDB :: DBVar stm (DeltaMap WalletId (DeltaWalletState s))
listWallets :: stm [WalletId]
removeWallet :: WalletId -> ExceptT ErrNoSuchWallet stm ()
initializeWallet :: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
atomically :: ()
prune :: ()
rollbackTo :: ()
readGenesisParameters :: ()
readPrivateKey :: ()
putPrivateKey :: ()
removePendingOrExpiredTx :: ()
updatePendingTxForExpiry :: ()
readLocalTxSubmissionPending :: ()
putLocalTxSubmission :: ()
getTx :: ()
readTxHistory :: ()
putTxHistory :: ()
readDelegationRewardBalance :: ()
putDelegationRewardBalance :: ()
putDelegationCertificate :: ()
isStakeKeyRegistered :: ()
readWalletMeta :: ()
putWalletMeta :: ()
listCheckpoints :: ()
readCheckpoint :: ()
putCheckpoint :: ()
walletsDB :: ()
listWallets :: ()
removeWallet :: ()
initializeWallet :: ()
..} -> do
    let g :: AddressPoolGap
g  = AddressPoolGap
defaultAddressPoolGap
    let s :: SeqState n k
s = (k 'RootK XPrv, Passphrase "encryption")
-> Index 'Hardened 'PurposeK -> AddressPoolGap -> SeqState n k
forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
(WalletKey k, SupportsDiscovery n k, (k == SharedKey) ~ 'False) =>
(k 'RootK XPrv, Passphrase "encryption")
-> Index 'Hardened 'PurposeK -> AddressPoolGap -> SeqState n k
mkSeqStateFromRootXPrv @n (k 'RootK XPrv, Passphrase "encryption")
credentials Index 'Hardened 'PurposeK
purposeBIP44 AddressPoolGap
g
    let ([(Tx, TxMeta)]
hist, Wallet (SeqState n k)
cp) = Block -> SeqState n k -> ([(Tx, TxMeta)], Wallet (SeqState n k))
forall s.
(IsOurs s Address, IsOurs s RewardAccount) =>
Block -> s -> ([(Tx, TxMeta)], Wallet s)
initWallet Block
block0 SeqState n k
s
    UTCTime
now <- IO UTCTime -> ExceptT ErrWalletAlreadyExists IO UTCTime
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
    let meta :: WalletMetadata
meta = WalletMetadata :: WalletName
-> UTCTime
-> Maybe WalletPassphraseInfo
-> WalletDelegation
-> WalletMetadata
WalletMetadata
            { $sel:name:WalletMetadata :: WalletName
name = WalletName
wname
            , $sel:creationTime:WalletMetadata :: UTCTime
creationTime = UTCTime
now
            , $sel:passphraseInfo:WalletMetadata :: Maybe WalletPassphraseInfo
passphraseInfo = Maybe WalletPassphraseInfo
forall a. Maybe a
Nothing
            , $sel:delegation:WalletMetadata :: WalletDelegation
delegation = WalletDelegationStatus
-> [WalletDelegationNext] -> WalletDelegation
WalletDelegation WalletDelegationStatus
NotDelegating []
            }
    (stm (Either ErrWalletAlreadyExists WalletId)
 -> IO (Either ErrWalletAlreadyExists WalletId))
-> ExceptT ErrWalletAlreadyExists stm WalletId
-> ExceptT ErrWalletAlreadyExists IO WalletId
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT stm (Either ErrWalletAlreadyExists WalletId)
-> IO (Either ErrWalletAlreadyExists WalletId)
forall a. stm a -> IO a
atomically (ExceptT ErrWalletAlreadyExists stm WalletId
 -> ExceptT ErrWalletAlreadyExists IO WalletId)
-> ExceptT ErrWalletAlreadyExists stm WalletId
-> ExceptT ErrWalletAlreadyExists IO WalletId
forall a b. (a -> b) -> a -> b
$
        WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
initializeWallet WalletId
wid Wallet s
Wallet (SeqState n k)
cp WalletMetadata
meta [(Tx, TxMeta)]
hist GenesisParameters
gp ExceptT ErrWalletAlreadyExists stm ()
-> WalletId -> ExceptT ErrWalletAlreadyExists stm WalletId
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> WalletId
wid
  where
    db :: DBLayer IO s k
db = ctx
ctx ctx
-> ((DBLayer IO s k -> Const (DBLayer IO s k) (DBLayer IO s k))
    -> ctx -> Const (DBLayer IO s k) ctx)
-> DBLayer IO s k
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx. HasDBLayer IO s k ctx => Lens' ctx (DBLayer IO s k)
forall (m :: * -> *) s (k :: Depth -> * -> *) ctx.
HasDBLayer m s k ctx =>
Lens' ctx (DBLayer m s k)
dbLayer @IO @s @k
    (Block
block0, NetworkParameters GenesisParameters
gp SlottingParameters
_sp ProtocolParameters
_pp) = ctx
ctx ctx
-> (((Block, NetworkParameters)
     -> Const (Block, NetworkParameters) (Block, NetworkParameters))
    -> ctx -> Const (Block, NetworkParameters) ctx)
-> (Block, NetworkParameters)
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. ((Block, NetworkParameters)
 -> Const (Block, NetworkParameters) (Block, NetworkParameters))
-> ctx -> Const (Block, NetworkParameters) ctx
forall s.
HasType (Block, NetworkParameters) s =>
Lens s s (Block, NetworkParameters) (Block, NetworkParameters)
genesisData

-- | Check whether a wallet is in good shape when restarting a worker.
checkWalletIntegrity
    :: forall ctx s k. HasDBLayer IO s k ctx
    => ctx
    -> WalletId
    -> GenesisParameters
    -> ExceptT ErrCheckWalletIntegrity IO ()
checkWalletIntegrity :: ctx
-> WalletId
-> GenesisParameters
-> ExceptT ErrCheckWalletIntegrity IO ()
checkWalletIntegrity ctx
ctx WalletId
wid GenesisParameters
gp = DBLayer IO s k
db DBLayer IO s k
-> (DBLayer IO s k -> ExceptT ErrCheckWalletIntegrity IO ())
-> ExceptT ErrCheckWalletIntegrity IO ()
forall a b. a -> (a -> b) -> b
& \DBLayer{stm [WalletId]
DBVar stm (DeltaMap WalletId (DeltaWalletState s))
WalletId -> stm [LocalTxSubmissionStatus SealedTx]
WalletId -> stm [ChainPoint]
WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
WalletId -> stm (Maybe GenesisParameters)
WalletId -> stm (Maybe WalletMetadata)
WalletId -> stm (Maybe (Wallet s))
WalletId -> stm Coin
WalletId -> ExceptT ErrNoSuchWallet stm Bool
WalletId -> ExceptT ErrNoSuchWallet stm ()
WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
forall a. stm a -> IO a
atomically :: forall a. stm a -> IO a
prune :: WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
rollbackTo :: WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
readGenesisParameters :: WalletId -> stm (Maybe GenesisParameters)
readPrivateKey :: WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
putPrivateKey :: WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
removePendingOrExpiredTx :: WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
updatePendingTxForExpiry :: WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
readLocalTxSubmissionPending :: WalletId -> stm [LocalTxSubmissionStatus SealedTx]
putLocalTxSubmission :: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
getTx :: WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
readTxHistory :: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
putTxHistory :: WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
readDelegationRewardBalance :: WalletId -> stm Coin
putDelegationRewardBalance :: WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
putDelegationCertificate :: WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
isStakeKeyRegistered :: WalletId -> ExceptT ErrNoSuchWallet stm Bool
readWalletMeta :: WalletId -> stm (Maybe WalletMetadata)
putWalletMeta :: WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
listCheckpoints :: WalletId -> stm [ChainPoint]
readCheckpoint :: WalletId -> stm (Maybe (Wallet s))
putCheckpoint :: WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
walletsDB :: DBVar stm (DeltaMap WalletId (DeltaWalletState s))
listWallets :: stm [WalletId]
removeWallet :: WalletId -> ExceptT ErrNoSuchWallet stm ()
initializeWallet :: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
atomically :: ()
prune :: ()
rollbackTo :: ()
readGenesisParameters :: ()
readPrivateKey :: ()
putPrivateKey :: ()
removePendingOrExpiredTx :: ()
updatePendingTxForExpiry :: ()
readLocalTxSubmissionPending :: ()
putLocalTxSubmission :: ()
getTx :: ()
readTxHistory :: ()
putTxHistory :: ()
readDelegationRewardBalance :: ()
putDelegationRewardBalance :: ()
putDelegationCertificate :: ()
isStakeKeyRegistered :: ()
readWalletMeta :: ()
putWalletMeta :: ()
listCheckpoints :: ()
readCheckpoint :: ()
putCheckpoint :: ()
walletsDB :: ()
listWallets :: ()
removeWallet :: ()
initializeWallet :: ()
..} -> (stm (Either ErrCheckWalletIntegrity ())
 -> IO (Either ErrCheckWalletIntegrity ()))
-> ExceptT ErrCheckWalletIntegrity stm ()
-> ExceptT ErrCheckWalletIntegrity IO ()
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT stm (Either ErrCheckWalletIntegrity ())
-> IO (Either ErrCheckWalletIntegrity ())
forall a. stm a -> IO a
atomically (ExceptT ErrCheckWalletIntegrity stm ()
 -> ExceptT ErrCheckWalletIntegrity IO ())
-> ExceptT ErrCheckWalletIntegrity stm ()
-> ExceptT ErrCheckWalletIntegrity IO ()
forall a b. (a -> b) -> a -> b
$ do
    GenesisParameters
gp' <- (ErrNoSuchWallet -> ErrCheckWalletIntegrity)
-> ExceptT ErrNoSuchWallet stm GenesisParameters
-> ExceptT ErrCheckWalletIntegrity stm GenesisParameters
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ErrNoSuchWallet -> ErrCheckWalletIntegrity
ErrCheckWalletIntegrityNoSuchWallet (ExceptT ErrNoSuchWallet stm GenesisParameters
 -> ExceptT ErrCheckWalletIntegrity stm GenesisParameters)
-> ExceptT ErrNoSuchWallet stm GenesisParameters
-> ExceptT ErrCheckWalletIntegrity stm GenesisParameters
forall a b. (a -> b) -> a -> b
$ WalletId
-> stm (Maybe GenesisParameters)
-> ExceptT ErrNoSuchWallet stm GenesisParameters
forall (m :: * -> *) a.
Monad m =>
WalletId -> m (Maybe a) -> ExceptT ErrNoSuchWallet m a
withNoSuchWallet WalletId
wid (stm (Maybe GenesisParameters)
 -> ExceptT ErrNoSuchWallet stm GenesisParameters)
-> stm (Maybe GenesisParameters)
-> ExceptT ErrNoSuchWallet stm GenesisParameters
forall a b. (a -> b) -> a -> b
$
        WalletId -> stm (Maybe GenesisParameters)
readGenesisParameters WalletId
wid

    GenesisParameters
-> GenesisParameters
-> ExceptT ErrCheckWalletIntegrity stm ()
-> ExceptT ErrCheckWalletIntegrity stm ()
forall (f :: * -> *) a a s s.
(Applicative f, Eq a, Eq a, HasField' "getGenesisBlockDate" s a,
 HasField' "getGenesisBlockDate" s a,
 HasField' "getGenesisBlockHash" s a,
 HasField' "getGenesisBlockHash" s a) =>
s -> s -> f () -> f ()
whenDifferentGenesis GenesisParameters
gp GenesisParameters
gp (ExceptT ErrCheckWalletIntegrity stm ()
 -> ExceptT ErrCheckWalletIntegrity stm ())
-> ExceptT ErrCheckWalletIntegrity stm ()
-> ExceptT ErrCheckWalletIntegrity stm ()
forall a b. (a -> b) -> a -> b
$ ErrCheckWalletIntegrity -> ExceptT ErrCheckWalletIntegrity stm ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (ErrCheckWalletIntegrity -> ExceptT ErrCheckWalletIntegrity stm ())
-> ErrCheckWalletIntegrity
-> ExceptT ErrCheckWalletIntegrity stm ()
forall a b. (a -> b) -> a -> b
$
        Hash "Genesis" -> Hash "Genesis" -> ErrCheckWalletIntegrity
ErrCheckIntegrityDifferentGenesis
            (GenesisParameters -> Hash "Genesis"
getGenesisBlockHash GenesisParameters
gp)
            (GenesisParameters -> Hash "Genesis"
getGenesisBlockHash GenesisParameters
gp')
  where
    db :: DBLayer IO s k
db = ctx
ctx ctx
-> ((DBLayer IO s k -> Const (DBLayer IO s k) (DBLayer IO s k))
    -> ctx -> Const (DBLayer IO s k) ctx)
-> DBLayer IO s k
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx. HasDBLayer IO s k ctx => Lens' ctx (DBLayer IO s k)
forall (m :: * -> *) s (k :: Depth -> * -> *) ctx.
HasDBLayer m s k ctx =>
Lens' ctx (DBLayer m s k)
dbLayer @IO @s @k
    whenDifferentGenesis :: s -> s -> f () -> f ()
whenDifferentGenesis s
bp1 s
bp2 = Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> f () -> f ()) -> Bool -> f () -> f ()
forall a b. (a -> b) -> a -> b
$
        (s
bp1 s -> ((a -> Const a a) -> s -> Const a s) -> a
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel "getGenesisBlockHash" ((a -> Const a a) -> s -> Const a s)
(a -> Const a a) -> s -> Const a s
#getGenesisBlockHash a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= s
bp2 s -> ((a -> Const a a) -> s -> Const a s) -> a
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel "getGenesisBlockHash" ((a -> Const a a) -> s -> Const a s)
(a -> Const a a) -> s -> Const a s
#getGenesisBlockHash) Bool -> Bool -> Bool
||
        (s
bp1 s -> ((a -> Const a a) -> s -> Const a s) -> a
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel "getGenesisBlockDate" ((a -> Const a a) -> s -> Const a s)
(a -> Const a a) -> s -> Const a s
#getGenesisBlockDate a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= s
bp2 s -> ((a -> Const a a) -> s -> Const a s) -> a
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel "getGenesisBlockDate" ((a -> Const a a) -> s -> Const a s)
(a -> Const a a) -> s -> Const a s
#getGenesisBlockDate)

-- | Retrieve the wallet state for the wallet with the given ID.
readWallet
    :: forall ctx s k. HasDBLayer IO s k ctx
    => ctx
    -> WalletId
    -> ExceptT ErrNoSuchWallet IO (Wallet s, WalletMetadata, Set Tx)
readWallet :: ctx
-> WalletId
-> ExceptT ErrNoSuchWallet IO (Wallet s, WalletMetadata, Set Tx)
readWallet ctx
ctx WalletId
wid = DBLayer IO s k
db DBLayer IO s k
-> (DBLayer IO s k
    -> ExceptT ErrNoSuchWallet IO (Wallet s, WalletMetadata, Set Tx))
-> ExceptT ErrNoSuchWallet IO (Wallet s, WalletMetadata, Set Tx)
forall a b. a -> (a -> b) -> b
& \DBLayer{stm [WalletId]
DBVar stm (DeltaMap WalletId (DeltaWalletState s))
WalletId -> stm [LocalTxSubmissionStatus SealedTx]
WalletId -> stm [ChainPoint]
WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
WalletId -> stm (Maybe GenesisParameters)
WalletId -> stm (Maybe WalletMetadata)
WalletId -> stm (Maybe (Wallet s))
WalletId -> stm Coin
WalletId -> ExceptT ErrNoSuchWallet stm Bool
WalletId -> ExceptT ErrNoSuchWallet stm ()
WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
forall a. stm a -> IO a
atomically :: forall a. stm a -> IO a
prune :: WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
rollbackTo :: WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
readGenesisParameters :: WalletId -> stm (Maybe GenesisParameters)
readPrivateKey :: WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
putPrivateKey :: WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
removePendingOrExpiredTx :: WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
updatePendingTxForExpiry :: WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
readLocalTxSubmissionPending :: WalletId -> stm [LocalTxSubmissionStatus SealedTx]
putLocalTxSubmission :: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
getTx :: WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
readTxHistory :: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
putTxHistory :: WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
readDelegationRewardBalance :: WalletId -> stm Coin
putDelegationRewardBalance :: WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
putDelegationCertificate :: WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
isStakeKeyRegistered :: WalletId -> ExceptT ErrNoSuchWallet stm Bool
readWalletMeta :: WalletId -> stm (Maybe WalletMetadata)
putWalletMeta :: WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
listCheckpoints :: WalletId -> stm [ChainPoint]
readCheckpoint :: WalletId -> stm (Maybe (Wallet s))
putCheckpoint :: WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
walletsDB :: DBVar stm (DeltaMap WalletId (DeltaWalletState s))
listWallets :: stm [WalletId]
removeWallet :: WalletId -> ExceptT ErrNoSuchWallet stm ()
initializeWallet :: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
atomically :: ()
prune :: ()
rollbackTo :: ()
readGenesisParameters :: ()
readPrivateKey :: ()
putPrivateKey :: ()
removePendingOrExpiredTx :: ()
updatePendingTxForExpiry :: ()
readLocalTxSubmissionPending :: ()
putLocalTxSubmission :: ()
getTx :: ()
readTxHistory :: ()
putTxHistory :: ()
readDelegationRewardBalance :: ()
putDelegationRewardBalance :: ()
putDelegationCertificate :: ()
isStakeKeyRegistered :: ()
readWalletMeta :: ()
putWalletMeta :: ()
listCheckpoints :: ()
readCheckpoint :: ()
putCheckpoint :: ()
walletsDB :: ()
listWallets :: ()
removeWallet :: ()
initializeWallet :: ()
..} -> (stm (Either ErrNoSuchWallet (Wallet s, WalletMetadata, Set Tx))
 -> IO (Either ErrNoSuchWallet (Wallet s, WalletMetadata, Set Tx)))
-> ExceptT ErrNoSuchWallet stm (Wallet s, WalletMetadata, Set Tx)
-> ExceptT ErrNoSuchWallet IO (Wallet s, WalletMetadata, Set Tx)
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT stm (Either ErrNoSuchWallet (Wallet s, WalletMetadata, Set Tx))
-> IO (Either ErrNoSuchWallet (Wallet s, WalletMetadata, Set Tx))
forall a. stm a -> IO a
atomically (ExceptT ErrNoSuchWallet stm (Wallet s, WalletMetadata, Set Tx)
 -> ExceptT ErrNoSuchWallet IO (Wallet s, WalletMetadata, Set Tx))
-> ExceptT ErrNoSuchWallet stm (Wallet s, WalletMetadata, Set Tx)
-> ExceptT ErrNoSuchWallet IO (Wallet s, WalletMetadata, Set Tx)
forall a b. (a -> b) -> a -> b
$ do
    Wallet s
cp <- WalletId
-> stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s)
forall (m :: * -> *) a.
Monad m =>
WalletId -> m (Maybe a) -> ExceptT ErrNoSuchWallet m a
withNoSuchWallet WalletId
wid (stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s))
-> stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s)
forall a b. (a -> b) -> a -> b
$ WalletId -> stm (Maybe (Wallet s))
readCheckpoint WalletId
wid
    WalletMetadata
meta <- WalletId
-> stm (Maybe WalletMetadata)
-> ExceptT ErrNoSuchWallet stm WalletMetadata
forall (m :: * -> *) a.
Monad m =>
WalletId -> m (Maybe a) -> ExceptT ErrNoSuchWallet m a
withNoSuchWallet WalletId
wid (stm (Maybe WalletMetadata)
 -> ExceptT ErrNoSuchWallet stm WalletMetadata)
-> stm (Maybe WalletMetadata)
-> ExceptT ErrNoSuchWallet stm WalletMetadata
forall a b. (a -> b) -> a -> b
$ WalletId -> stm (Maybe WalletMetadata)
readWalletMeta WalletId
wid
    [TransactionInfo]
pending <- stm [TransactionInfo]
-> ExceptT ErrNoSuchWallet stm [TransactionInfo]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (stm [TransactionInfo]
 -> ExceptT ErrNoSuchWallet stm [TransactionInfo])
-> stm [TransactionInfo]
-> ExceptT ErrNoSuchWallet stm [TransactionInfo]
forall a b. (a -> b) -> a -> b
$ WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
readTxHistory WalletId
wid Maybe Coin
forall a. Maybe a
Nothing SortOrder
Descending Range SlotNo
forall a. Range a
wholeRange (TxStatus -> Maybe TxStatus
forall a. a -> Maybe a
Just TxStatus
Pending)
    (Wallet s, WalletMetadata, Set Tx)
-> ExceptT ErrNoSuchWallet stm (Wallet s, WalletMetadata, Set Tx)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Wallet s
cp, WalletMetadata
meta, [Tx] -> Set Tx
forall a. Ord a => [a] -> Set a
Set.fromList (TransactionInfo -> Tx
fromTransactionInfo (TransactionInfo -> Tx) -> [TransactionInfo] -> [Tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TransactionInfo]
pending))
  where
    db :: DBLayer IO s k
db = ctx
ctx ctx
-> ((DBLayer IO s k -> Const (DBLayer IO s k) (DBLayer IO s k))
    -> ctx -> Const (DBLayer IO s k) ctx)
-> DBLayer IO s k
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx. HasDBLayer IO s k ctx => Lens' ctx (DBLayer IO s k)
forall (m :: * -> *) s (k :: Depth -> * -> *) ctx.
HasDBLayer m s k ctx =>
Lens' ctx (DBLayer m s k)
dbLayer @IO @s @k

walletSyncProgress
    :: forall ctx s. HasNetworkLayer IO ctx
    => ctx
    -> Wallet s
    -> IO SyncProgress
walletSyncProgress :: ctx -> Wallet s -> IO SyncProgress
walletSyncProgress ctx
ctx Wallet s
w = do
    let tip :: SlotNo
tip = ((SlotNo -> Const SlotNo SlotNo)
 -> BlockHeader -> Const SlotNo BlockHeader)
-> BlockHeader -> SlotNo
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "slotNo"
  ((SlotNo -> Const SlotNo SlotNo)
   -> BlockHeader -> Const SlotNo BlockHeader)
(SlotNo -> Const SlotNo SlotNo)
-> BlockHeader -> Const SlotNo BlockHeader
#slotNo (BlockHeader -> SlotNo) -> BlockHeader -> SlotNo
forall a b. (a -> b) -> a -> b
$ Wallet s -> BlockHeader
forall s. Wallet s -> BlockHeader
currentTip Wallet s
w
    NetworkLayer IO Block -> SlotNo -> IO SyncProgress
forall (m :: * -> *) block.
NetworkLayer m block -> SlotNo -> m SyncProgress
syncProgress NetworkLayer IO Block
nl SlotNo
tip
  where
    nl :: NetworkLayer IO Block
nl = ctx
ctx ctx
-> ((NetworkLayer IO Block
     -> Const (NetworkLayer IO Block) (NetworkLayer IO Block))
    -> ctx -> Const (NetworkLayer IO Block) ctx)
-> NetworkLayer IO Block
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. (NetworkLayer IO Block
 -> Const (NetworkLayer IO Block) (NetworkLayer IO Block))
-> ctx -> Const (NetworkLayer IO Block) ctx
forall (m :: * -> *) ctx.
HasNetworkLayer m ctx =>
Lens' ctx (NetworkLayer m Block)
networkLayer

-- | Update a wallet's metadata with the given update function.
updateWallet
    :: forall ctx s k.
        ( HasDBLayer IO s k ctx
        )
    => ctx
    -> WalletId
    -> (WalletMetadata -> WalletMetadata)
    -> ExceptT ErrNoSuchWallet IO ()
updateWallet :: ctx
-> WalletId
-> (WalletMetadata -> WalletMetadata)
-> ExceptT ErrNoSuchWallet IO ()
updateWallet ctx
ctx WalletId
wid WalletMetadata -> WalletMetadata
modify = DBLayer IO s k
db DBLayer IO s k
-> (DBLayer IO s k -> ExceptT ErrNoSuchWallet IO ())
-> ExceptT ErrNoSuchWallet IO ()
forall a b. a -> (a -> b) -> b
& \DBLayer{stm [WalletId]
DBVar stm (DeltaMap WalletId (DeltaWalletState s))
WalletId -> stm [LocalTxSubmissionStatus SealedTx]
WalletId -> stm [ChainPoint]
WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
WalletId -> stm (Maybe GenesisParameters)
WalletId -> stm (Maybe WalletMetadata)
WalletId -> stm (Maybe (Wallet s))
WalletId -> stm Coin
WalletId -> ExceptT ErrNoSuchWallet stm Bool
WalletId -> ExceptT ErrNoSuchWallet stm ()
WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
forall a. stm a -> IO a
atomically :: forall a. stm a -> IO a
prune :: WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
rollbackTo :: WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
readGenesisParameters :: WalletId -> stm (Maybe GenesisParameters)
readPrivateKey :: WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
putPrivateKey :: WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
removePendingOrExpiredTx :: WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
updatePendingTxForExpiry :: WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
readLocalTxSubmissionPending :: WalletId -> stm [LocalTxSubmissionStatus SealedTx]
putLocalTxSubmission :: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
getTx :: WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
readTxHistory :: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
putTxHistory :: WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
readDelegationRewardBalance :: WalletId -> stm Coin
putDelegationRewardBalance :: WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
putDelegationCertificate :: WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
isStakeKeyRegistered :: WalletId -> ExceptT ErrNoSuchWallet stm Bool
readWalletMeta :: WalletId -> stm (Maybe WalletMetadata)
putWalletMeta :: WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
listCheckpoints :: WalletId -> stm [ChainPoint]
readCheckpoint :: WalletId -> stm (Maybe (Wallet s))
putCheckpoint :: WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
walletsDB :: DBVar stm (DeltaMap WalletId (DeltaWalletState s))
listWallets :: stm [WalletId]
removeWallet :: WalletId -> ExceptT ErrNoSuchWallet stm ()
initializeWallet :: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
atomically :: ()
prune :: ()
rollbackTo :: ()
readGenesisParameters :: ()
readPrivateKey :: ()
putPrivateKey :: ()
removePendingOrExpiredTx :: ()
updatePendingTxForExpiry :: ()
readLocalTxSubmissionPending :: ()
putLocalTxSubmission :: ()
getTx :: ()
readTxHistory :: ()
putTxHistory :: ()
readDelegationRewardBalance :: ()
putDelegationRewardBalance :: ()
putDelegationCertificate :: ()
isStakeKeyRegistered :: ()
readWalletMeta :: ()
putWalletMeta :: ()
listCheckpoints :: ()
readCheckpoint :: ()
putCheckpoint :: ()
walletsDB :: ()
listWallets :: ()
removeWallet :: ()
initializeWallet :: ()
..} -> (stm (Either ErrNoSuchWallet ()) -> IO (Either ErrNoSuchWallet ()))
-> ExceptT ErrNoSuchWallet stm () -> ExceptT ErrNoSuchWallet IO ()
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT stm (Either ErrNoSuchWallet ()) -> IO (Either ErrNoSuchWallet ())
forall a. stm a -> IO a
atomically (ExceptT ErrNoSuchWallet stm () -> ExceptT ErrNoSuchWallet IO ())
-> ExceptT ErrNoSuchWallet stm () -> ExceptT ErrNoSuchWallet IO ()
forall a b. (a -> b) -> a -> b
$ do
    WalletMetadata
meta <- WalletId
-> stm (Maybe WalletMetadata)
-> ExceptT ErrNoSuchWallet stm WalletMetadata
forall (m :: * -> *) a.
Monad m =>
WalletId -> m (Maybe a) -> ExceptT ErrNoSuchWallet m a
withNoSuchWallet WalletId
wid (stm (Maybe WalletMetadata)
 -> ExceptT ErrNoSuchWallet stm WalletMetadata)
-> stm (Maybe WalletMetadata)
-> ExceptT ErrNoSuchWallet stm WalletMetadata
forall a b. (a -> b) -> a -> b
$ WalletId -> stm (Maybe WalletMetadata)
readWalletMeta WalletId
wid
    WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
putWalletMeta WalletId
wid (WalletMetadata -> WalletMetadata
modify WalletMetadata
meta)
  where
    db :: DBLayer IO s k
db = ctx
ctx ctx
-> ((DBLayer IO s k -> Const (DBLayer IO s k) (DBLayer IO s k))
    -> ctx -> Const (DBLayer IO s k) ctx)
-> DBLayer IO s k
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx. HasDBLayer IO s k ctx => Lens' ctx (DBLayer IO s k)
forall (m :: * -> *) s (k :: Depth -> * -> *) ctx.
HasDBLayer m s k ctx =>
Lens' ctx (DBLayer m s k)
dbLayer @IO @s @k

-- | Change a wallet's passphrase to the given passphrase.
updateWalletPassphraseWithOldPassphrase
    :: forall ctx s k.
        ( HasDBLayer IO s k ctx
        , WalletKey k
        )
    => ctx
    -> WalletId
    -> (Passphrase "user", Passphrase "user")
    -> ExceptT ErrUpdatePassphrase IO ()
updateWalletPassphraseWithOldPassphrase :: ctx
-> WalletId
-> (Passphrase "user", Passphrase "user")
-> ExceptT ErrUpdatePassphrase IO ()
updateWalletPassphraseWithOldPassphrase ctx
ctx WalletId
wid (Passphrase "user"
old, Passphrase "user"
new) =
    ctx
-> WalletId
-> Passphrase "user"
-> (ErrWithRootKey -> ErrUpdatePassphrase)
-> (k 'RootK XPrv
    -> PassphraseScheme -> ExceptT ErrUpdatePassphrase IO ())
-> ExceptT ErrUpdatePassphrase IO ()
forall ctx s (k :: Depth -> * -> *) e a.
HasDBLayer IO s k ctx =>
ctx
-> WalletId
-> Passphrase "user"
-> (ErrWithRootKey -> e)
-> (k 'RootK XPrv -> PassphraseScheme -> ExceptT e IO a)
-> ExceptT e IO a
withRootKey @ctx @s @k ctx
ctx WalletId
wid Passphrase "user"
old ErrWithRootKey -> ErrUpdatePassphrase
ErrUpdatePassphraseWithRootKey
        ((k 'RootK XPrv
  -> PassphraseScheme -> ExceptT ErrUpdatePassphrase IO ())
 -> ExceptT ErrUpdatePassphrase IO ())
-> (k 'RootK XPrv
    -> PassphraseScheme -> ExceptT ErrUpdatePassphrase IO ())
-> ExceptT ErrUpdatePassphrase IO ()
forall a b. (a -> b) -> a -> b
$ \k 'RootK XPrv
xprv PassphraseScheme
scheme -> (ErrNoSuchWallet -> ErrUpdatePassphrase)
-> ExceptT ErrNoSuchWallet IO ()
-> ExceptT ErrUpdatePassphrase IO ()
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ErrNoSuchWallet -> ErrUpdatePassphrase
ErrUpdatePassphraseNoSuchWallet (ExceptT ErrNoSuchWallet IO ()
 -> ExceptT ErrUpdatePassphrase IO ())
-> ExceptT ErrNoSuchWallet IO ()
-> ExceptT ErrUpdatePassphrase IO ()
forall a b. (a -> b) -> a -> b
$ do
            -- IMPORTANT NOTE:
            -- This use 'EncryptWithPBKDF2', regardless of the passphrase
            -- current scheme, we'll re-encrypt it using the current scheme,
            -- always.
            let new' :: (PassphraseScheme, Passphrase "user")
new' = (PassphraseScheme
currentPassphraseScheme, Passphrase "user"
new)
            let xprv' :: k 'RootK XPrv
xprv' = (PassphraseScheme, Passphrase "user")
-> (PassphraseScheme, Passphrase "user")
-> k 'RootK XPrv
-> k 'RootK XPrv
forall (key :: Depth -> * -> *) (depth :: Depth).
WalletKey key =>
(PassphraseScheme, Passphrase "user")
-> (PassphraseScheme, Passphrase "user")
-> key depth XPrv
-> key depth XPrv
changePassphrase (PassphraseScheme
scheme, Passphrase "user"
old) (PassphraseScheme, Passphrase "user")
new' k 'RootK XPrv
xprv
            ctx
-> WalletId
-> (k 'RootK XPrv, (PassphraseScheme, Passphrase "user"))
-> ExceptT ErrNoSuchWallet IO ()
forall ctx s (k :: Depth -> * -> *).
HasDBLayer IO s k ctx =>
ctx
-> WalletId
-> (k 'RootK XPrv, (PassphraseScheme, Passphrase "user"))
-> ExceptT ErrNoSuchWallet IO ()
attachPrivateKeyFromPwdScheme @ctx @s @k ctx
ctx WalletId
wid (k 'RootK XPrv
xprv', (PassphraseScheme, Passphrase "user")
new')

updateWalletPassphraseWithMnemonic
    :: forall ctx s k.
        ( HasDBLayer IO s k ctx
        )
    => ctx
    -> WalletId
    -> (k 'RootK XPrv, Passphrase "user")
    -> ExceptT ErrUpdatePassphrase IO ()
updateWalletPassphraseWithMnemonic :: ctx
-> WalletId
-> (k 'RootK XPrv, Passphrase "user")
-> ExceptT ErrUpdatePassphrase IO ()
updateWalletPassphraseWithMnemonic ctx
ctx WalletId
wid (k 'RootK XPrv
xprv, Passphrase "user"
new) =
    (ErrNoSuchWallet -> ErrUpdatePassphrase)
-> ExceptT ErrNoSuchWallet IO ()
-> ExceptT ErrUpdatePassphrase IO ()
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ErrNoSuchWallet -> ErrUpdatePassphrase
ErrUpdatePassphraseNoSuchWallet (ExceptT ErrNoSuchWallet IO ()
 -> ExceptT ErrUpdatePassphrase IO ())
-> ExceptT ErrNoSuchWallet IO ()
-> ExceptT ErrUpdatePassphrase IO ()
forall a b. (a -> b) -> a -> b
$ do
        ctx
-> WalletId
-> (k 'RootK XPrv, (PassphraseScheme, Passphrase "user"))
-> ExceptT ErrNoSuchWallet IO ()
forall ctx s (k :: Depth -> * -> *).
HasDBLayer IO s k ctx =>
ctx
-> WalletId
-> (k 'RootK XPrv, (PassphraseScheme, Passphrase "user"))
-> ExceptT ErrNoSuchWallet IO ()
attachPrivateKeyFromPwdScheme @ctx @s @k ctx
ctx WalletId
wid
            (k 'RootK XPrv
xprv, (PassphraseScheme
currentPassphraseScheme , Passphrase "user"
new))

getWalletUtxoSnapshot
    :: forall ctx s k.
        ( HasDBLayer IO s k ctx
        , HasNetworkLayer IO ctx
        , HasTransactionLayer k ctx
        )
    => ctx
    -> WalletId
    -> ExceptT ErrNoSuchWallet IO [(TokenBundle, Coin)]
getWalletUtxoSnapshot :: ctx -> WalletId -> ExceptT ErrNoSuchWallet IO [(TokenBundle, Coin)]
getWalletUtxoSnapshot ctx
ctx WalletId
wid = do
    (Wallet s
wallet, WalletMetadata
_, Set Tx
pending) <- (ErrNoSuchWallet -> ErrNoSuchWallet)
-> ExceptT ErrNoSuchWallet IO (Wallet s, WalletMetadata, Set Tx)
-> ExceptT ErrNoSuchWallet IO (Wallet s, WalletMetadata, Set Tx)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ErrNoSuchWallet -> ErrNoSuchWallet
forall a. a -> a
id (ctx
-> WalletId
-> ExceptT ErrNoSuchWallet IO (Wallet s, WalletMetadata, Set Tx)
forall ctx s (k :: Depth -> * -> *).
HasDBLayer IO s k ctx =>
ctx
-> WalletId
-> ExceptT ErrNoSuchWallet IO (Wallet s, WalletMetadata, Set Tx)
readWallet @ctx @s @k ctx
ctx WalletId
wid)
    ProtocolParameters
pp <- IO ProtocolParameters
-> ExceptT ErrNoSuchWallet IO ProtocolParameters
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProtocolParameters
 -> ExceptT ErrNoSuchWallet IO ProtocolParameters)
-> IO ProtocolParameters
-> ExceptT ErrNoSuchWallet IO ProtocolParameters
forall a b. (a -> b) -> a -> b
$ NetworkLayer IO Block -> IO ProtocolParameters
forall (m :: * -> *) block.
NetworkLayer m block -> m ProtocolParameters
currentProtocolParameters NetworkLayer IO Block
nl
    AnyCardanoEra
era <- IO AnyCardanoEra -> ExceptT ErrNoSuchWallet IO AnyCardanoEra
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO AnyCardanoEra -> ExceptT ErrNoSuchWallet IO AnyCardanoEra)
-> IO AnyCardanoEra -> ExceptT ErrNoSuchWallet IO AnyCardanoEra
forall a b. (a -> b) -> a -> b
$ NetworkLayer IO Block -> IO AnyCardanoEra
forall (m :: * -> *) block. NetworkLayer m block -> m AnyCardanoEra
currentNodeEra NetworkLayer IO Block
nl
    let txOuts :: [TxOut]
txOuts = Set Tx -> Wallet s -> UTxO
forall s. Set Tx -> Wallet s -> UTxO
availableUTxO @s Set Tx
pending Wallet s
wallet
            UTxO -> (UTxO -> Map TxIn TxOut) -> Map TxIn TxOut
forall a b. a -> (a -> b) -> b
& UTxO -> Map TxIn TxOut
unUTxO
            Map TxIn TxOut -> (Map TxIn TxOut -> [TxOut]) -> [TxOut]
forall a b. a -> (a -> b) -> b
& Map TxIn TxOut -> [TxOut]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList
    [(TokenBundle, Coin)]
-> ExceptT ErrNoSuchWallet IO [(TokenBundle, Coin)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(TokenBundle, Coin)]
 -> ExceptT ErrNoSuchWallet IO [(TokenBundle, Coin)])
-> [(TokenBundle, Coin)]
-> ExceptT ErrNoSuchWallet IO [(TokenBundle, Coin)]
forall a b. (a -> b) -> a -> b
$ (TxOut -> TokenBundle) -> (TxOut, Coin) -> (TokenBundle, Coin)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (((TokenBundle -> Const TokenBundle TokenBundle)
 -> TxOut -> Const TokenBundle TxOut)
-> TxOut -> TokenBundle
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "tokens"
  ((TokenBundle -> Const TokenBundle TokenBundle)
   -> TxOut -> Const TokenBundle TxOut)
(TokenBundle -> Const TokenBundle TokenBundle)
-> TxOut -> Const TokenBundle TxOut
#tokens) ((TxOut, Coin) -> (TokenBundle, Coin))
-> (TxOut -> (TxOut, Coin)) -> TxOut -> (TokenBundle, Coin)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnyCardanoEra -> ProtocolParameters -> TxOut -> (TxOut, Coin)
pairTxOutWithMinAdaQuantity AnyCardanoEra
era ProtocolParameters
pp (TxOut -> (TokenBundle, Coin)) -> [TxOut] -> [(TokenBundle, Coin)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TxOut]
txOuts
  where
    nl :: NetworkLayer IO Block
nl = ctx
ctx ctx
-> ((NetworkLayer IO Block
     -> Const (NetworkLayer IO Block) (NetworkLayer IO Block))
    -> ctx -> Const (NetworkLayer IO Block) ctx)
-> NetworkLayer IO Block
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. (NetworkLayer IO Block
 -> Const (NetworkLayer IO Block) (NetworkLayer IO Block))
-> ctx -> Const (NetworkLayer IO Block) ctx
forall (m :: * -> *) ctx.
HasNetworkLayer m ctx =>
Lens' ctx (NetworkLayer m Block)
networkLayer
    tl :: TransactionLayer k SealedTx
tl = ctx
ctx ctx
-> ((TransactionLayer k SealedTx
     -> Const
          (TransactionLayer k SealedTx) (TransactionLayer k SealedTx))
    -> ctx -> Const (TransactionLayer k SealedTx) ctx)
-> TransactionLayer k SealedTx
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx.
HasTransactionLayer k ctx =>
Lens' ctx (TransactionLayer k SealedTx)
forall (k :: Depth -> * -> *) ctx.
HasTransactionLayer k ctx =>
Lens' ctx (TransactionLayer k SealedTx)
transactionLayer @k

    pairTxOutWithMinAdaQuantity
        :: Cardano.AnyCardanoEra
        -> ProtocolParameters
        -> TxOut
        -> (TxOut, Coin)
    pairTxOutWithMinAdaQuantity :: AnyCardanoEra -> ProtocolParameters -> TxOut -> (TxOut, Coin)
pairTxOutWithMinAdaQuantity AnyCardanoEra
era ProtocolParameters
pp TxOut
out =
        (TxOut
out, TxOut -> Coin
computeMinAdaQuantity TxOut
out)
      where
        computeMinAdaQuantity :: TxOut -> Coin
        computeMinAdaQuantity :: TxOut -> Coin
computeMinAdaQuantity (TxOut Address
addr TokenBundle
bundle) =
            (((Address -> TokenMap -> Coin)
  -> Const
       (Address -> TokenMap -> Coin) (Address -> TokenMap -> Coin))
 -> TxConstraints
 -> Const (Address -> TokenMap -> Coin) TxConstraints)
-> TxConstraints -> Address -> TokenMap -> Coin
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "txOutputMinimumAdaQuantity"
  (((Address -> TokenMap -> Coin)
    -> Const
         (Address -> TokenMap -> Coin) (Address -> TokenMap -> Coin))
   -> TxConstraints
   -> Const (Address -> TokenMap -> Coin) TxConstraints)
((Address -> TokenMap -> Coin)
 -> Const
      (Address -> TokenMap -> Coin) (Address -> TokenMap -> Coin))
-> TxConstraints
-> Const (Address -> TokenMap -> Coin) TxConstraints
#txOutputMinimumAdaQuantity
                (TransactionLayer k SealedTx
-> AnyCardanoEra -> ProtocolParameters -> TxConstraints
forall (k :: Depth -> * -> *) tx.
TransactionLayer k tx
-> AnyCardanoEra -> ProtocolParameters -> TxConstraints
constraints TransactionLayer k SealedTx
tl AnyCardanoEra
era ProtocolParameters
pp)
                (Address
addr)
                (((TokenMap -> Const TokenMap TokenMap)
 -> TokenBundle -> Const TokenMap TokenBundle)
-> TokenBundle -> TokenMap
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "tokens"
  ((TokenMap -> Const TokenMap TokenMap)
   -> TokenBundle -> Const TokenMap TokenBundle)
(TokenMap -> Const TokenMap TokenMap)
-> TokenBundle -> Const TokenMap TokenBundle
#tokens TokenBundle
bundle)

-- | List the wallet's UTxO statistics.
listUtxoStatistics
    :: forall ctx s k. HasDBLayer IO s k ctx
    => ctx
    -> WalletId
    -> ExceptT ErrListUTxOStatistics IO UTxOStatistics
listUtxoStatistics :: ctx -> WalletId -> ExceptT ErrListUTxOStatistics IO UTxOStatistics
listUtxoStatistics ctx
ctx WalletId
wid = do
    (Wallet s
wal, WalletMetadata
_, Set Tx
pending) <- (ErrNoSuchWallet -> ErrListUTxOStatistics)
-> ExceptT ErrNoSuchWallet IO (Wallet s, WalletMetadata, Set Tx)
-> ExceptT
     ErrListUTxOStatistics IO (Wallet s, WalletMetadata, Set Tx)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT
        ErrNoSuchWallet -> ErrListUTxOStatistics
ErrListUTxOStatisticsNoSuchWallet (ctx
-> WalletId
-> ExceptT ErrNoSuchWallet IO (Wallet s, WalletMetadata, Set Tx)
forall ctx s (k :: Depth -> * -> *).
HasDBLayer IO s k ctx =>
ctx
-> WalletId
-> ExceptT ErrNoSuchWallet IO (Wallet s, WalletMetadata, Set Tx)
readWallet @ctx @s @k ctx
ctx WalletId
wid)
    let utxo :: UTxO
utxo = Set Tx -> Wallet s -> UTxO
forall s. Set Tx -> Wallet s -> UTxO
availableUTxO @s Set Tx
pending Wallet s
wal
    UTxOStatistics -> ExceptT ErrListUTxOStatistics IO UTxOStatistics
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTxOStatistics -> ExceptT ErrListUTxOStatistics IO UTxOStatistics)
-> UTxOStatistics
-> ExceptT ErrListUTxOStatistics IO UTxOStatistics
forall a b. (a -> b) -> a -> b
$ BoundType -> UTxO -> UTxOStatistics
computeUtxoStatistics BoundType
log10 UTxO
utxo

-- | Restore a wallet from its current tip.
--
-- After the wallet has been restored,
-- this action will continue to fetch newly created blocks
-- and apply them, or roll back to a previous point whenever
-- the chain switches.
restoreWallet
    :: forall ctx s k.
        ( HasNetworkLayer IO ctx
        , HasDBLayer IO s k ctx
        , HasLogger IO WalletWorkerLog ctx
        , IsOurs s Address
        , IsOurs s RewardAccount
        , AddressBookIso s
        , MaybeLight s
        )
    => ctx
    -> WalletId
    -> ExceptT ErrNoSuchWallet IO ()
restoreWallet :: ctx -> WalletId -> ExceptT ErrNoSuchWallet IO ()
restoreWallet ctx
ctx WalletId
wid = DBLayer IO s k
db DBLayer IO s k
-> (DBLayer IO s k -> ExceptT ErrNoSuchWallet IO ())
-> ExceptT ErrNoSuchWallet IO ()
forall a b. a -> (a -> b) -> b
& \DBLayer{stm [WalletId]
DBVar stm (DeltaMap WalletId (DeltaWalletState s))
WalletId -> stm [LocalTxSubmissionStatus SealedTx]
WalletId -> stm [ChainPoint]
WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
WalletId -> stm (Maybe GenesisParameters)
WalletId -> stm (Maybe WalletMetadata)
WalletId -> stm (Maybe (Wallet s))
WalletId -> stm Coin
WalletId -> ExceptT ErrNoSuchWallet stm Bool
WalletId -> ExceptT ErrNoSuchWallet stm ()
WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
forall a. stm a -> IO a
atomically :: forall a. stm a -> IO a
prune :: WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
rollbackTo :: WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
readGenesisParameters :: WalletId -> stm (Maybe GenesisParameters)
readPrivateKey :: WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
putPrivateKey :: WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
removePendingOrExpiredTx :: WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
updatePendingTxForExpiry :: WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
readLocalTxSubmissionPending :: WalletId -> stm [LocalTxSubmissionStatus SealedTx]
putLocalTxSubmission :: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
getTx :: WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
readTxHistory :: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
putTxHistory :: WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
readDelegationRewardBalance :: WalletId -> stm Coin
putDelegationRewardBalance :: WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
putDelegationCertificate :: WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
isStakeKeyRegistered :: WalletId -> ExceptT ErrNoSuchWallet stm Bool
readWalletMeta :: WalletId -> stm (Maybe WalletMetadata)
putWalletMeta :: WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
listCheckpoints :: WalletId -> stm [ChainPoint]
readCheckpoint :: WalletId -> stm (Maybe (Wallet s))
putCheckpoint :: WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
walletsDB :: DBVar stm (DeltaMap WalletId (DeltaWalletState s))
listWallets :: stm [WalletId]
removeWallet :: WalletId -> ExceptT ErrNoSuchWallet stm ()
initializeWallet :: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
atomically :: ()
prune :: ()
rollbackTo :: ()
readGenesisParameters :: ()
readPrivateKey :: ()
putPrivateKey :: ()
removePendingOrExpiredTx :: ()
updatePendingTxForExpiry :: ()
readLocalTxSubmissionPending :: ()
putLocalTxSubmission :: ()
getTx :: ()
readTxHistory :: ()
putTxHistory :: ()
readDelegationRewardBalance :: ()
putDelegationRewardBalance :: ()
putDelegationCertificate :: ()
isStakeKeyRegistered :: ()
readWalletMeta :: ()
putWalletMeta :: ()
listCheckpoints :: ()
readCheckpoint :: ()
putCheckpoint :: ()
walletsDB :: ()
listWallets :: ()
removeWallet :: ()
initializeWallet :: ()
..} ->
    let checkpointPolicy :: BlockHeight -> CheckpointPolicy
checkpointPolicy = BlockHeight -> CheckpointPolicy
CP.defaultPolicy
        readChainPoints :: IO [ChainPoint]
readChainPoints = stm [ChainPoint] -> IO [ChainPoint]
forall a. stm a -> IO a
atomically (stm [ChainPoint] -> IO [ChainPoint])
-> stm [ChainPoint] -> IO [ChainPoint]
forall a b. (a -> b) -> a -> b
$ WalletId -> stm [ChainPoint]
listCheckpoints WalletId
wid
        rollBackward :: ChainPoint -> IO ChainPoint
rollBackward =
            ExceptT ErrNoSuchWallet IO ChainPoint -> IO ChainPoint
forall a. ExceptT ErrNoSuchWallet IO a -> IO a
throwInIO (ExceptT ErrNoSuchWallet IO ChainPoint -> IO ChainPoint)
-> (ChainPoint -> ExceptT ErrNoSuchWallet IO ChainPoint)
-> ChainPoint
-> IO ChainPoint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ctx -> WalletId -> Slot -> ExceptT ErrNoSuchWallet IO ChainPoint
forall ctx s (k :: Depth -> * -> *).
HasDBLayer IO s k ctx =>
ctx -> WalletId -> Slot -> ExceptT ErrNoSuchWallet IO ChainPoint
rollbackBlocks @_ @s @k ctx
ctx WalletId
wid (Slot -> ExceptT ErrNoSuchWallet IO ChainPoint)
-> (ChainPoint -> Slot)
-> ChainPoint
-> ExceptT ErrNoSuchWallet IO ChainPoint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainPoint -> Slot
toSlot
        rollForward' :: BlockData IO (Either Address RewardAccount) ChainEvents s
-> BlockHeader -> IO ()
rollForward' = \BlockData IO (Either Address RewardAccount) ChainEvents s
blockdata BlockHeader
tip -> ExceptT ErrNoSuchWallet IO () -> IO ()
forall a. ExceptT ErrNoSuchWallet IO a -> IO a
throwInIO (ExceptT ErrNoSuchWallet IO () -> IO ())
-> ExceptT ErrNoSuchWallet IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            ctx
-> Tracer IO WalletFollowLog
-> WalletId
-> BlockData IO (Either Address RewardAccount) ChainEvents s
-> BlockHeader
-> ExceptT ErrNoSuchWallet IO ()
forall ctx s (k :: Depth -> * -> *).
(HasDBLayer IO s k ctx, HasNetworkLayer IO ctx, IsOurs s Address,
 IsOurs s RewardAccount, AddressBookIso s) =>
ctx
-> Tracer IO WalletFollowLog
-> WalletId
-> BlockData IO (Either Address RewardAccount) ChainEvents s
-> BlockHeader
-> ExceptT ErrNoSuchWallet IO ()
restoreBlocks @_ @s @k
                ctx
ctx ((WalletFollowLog -> WalletWorkerLog)
-> Tracer IO WalletWorkerLog -> Tracer IO WalletFollowLog
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap WalletFollowLog -> WalletWorkerLog
MsgWalletFollow Tracer IO WalletWorkerLog
tr) WalletId
wid BlockData IO (Either Address RewardAccount) ChainEvents s
blockdata BlockHeader
tip
    in
      IO () -> ExceptT ErrNoSuchWallet IO ()
forall a. IO a -> ExceptT ErrNoSuchWallet IO a
catchFromIO (IO () -> ExceptT ErrNoSuchWallet IO ())
-> IO () -> ExceptT ErrNoSuchWallet IO ()
forall a b. (a -> b) -> a -> b
$ case (Maybe (LightDiscoverTxs s)
forall s. MaybeLight s => Maybe (LightDiscoverTxs s)
maybeDiscover, NetworkLayer IO Block
-> Maybe
     (ChainFollower IO ChainPoint BlockHeader (LightBlocks IO Block)
      -> IO ())
forall (m :: * -> *) block.
NetworkLayer m block
-> Maybe
     (ChainFollower m ChainPoint BlockHeader (LightBlocks m Block)
      -> m ())
lightSync NetworkLayer IO Block
nw) of
        (Just LightDiscoverTxs s
discover, Just ChainFollower IO ChainPoint BlockHeader (LightBlocks IO Block)
-> IO ()
sync) ->
            ChainFollower IO ChainPoint BlockHeader (LightBlocks IO Block)
-> IO ()
sync (ChainFollower IO ChainPoint BlockHeader (LightBlocks IO Block)
 -> IO ())
-> ChainFollower IO ChainPoint BlockHeader (LightBlocks IO Block)
-> IO ()
forall a b. (a -> b) -> a -> b
$ ChainFollower :: forall (m :: * -> *) point tip blocks.
(BlockHeight -> CheckpointPolicy)
-> m [point]
-> (blocks -> tip -> m ())
-> (point -> m point)
-> ChainFollower m point tip blocks
ChainFollower
                { BlockHeight -> CheckpointPolicy
checkpointPolicy :: BlockHeight -> CheckpointPolicy
checkpointPolicy :: BlockHeight -> CheckpointPolicy
checkpointPolicy
                , IO [ChainPoint]
readChainPoints :: IO [ChainPoint]
readChainPoints :: IO [ChainPoint]
readChainPoints
                , rollForward :: LightBlocks IO Block -> BlockHeader -> IO ()
rollForward = BlockData IO (Either Address RewardAccount) ChainEvents s
-> BlockHeader -> IO ()
rollForward' (BlockData IO (Either Address RewardAccount) ChainEvents s
 -> BlockHeader -> IO ())
-> (LightBlocks IO Block
    -> BlockData IO (Either Address RewardAccount) ChainEvents s)
-> LightBlocks IO Block
-> BlockHeader
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty Block
 -> BlockData IO (Either Address RewardAccount) ChainEvents s)
-> (BlockSummary IO (Either Address RewardAccount) ChainEvents
    -> BlockData IO (Either Address RewardAccount) ChainEvents s)
-> LightBlocks IO Block
-> BlockData IO (Either Address RewardAccount) ChainEvents s
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either NonEmpty Block
-> BlockData IO (Either Address RewardAccount) ChainEvents s
forall (m :: * -> *) addr tx s.
NonEmpty Block -> BlockData m addr tx s
List (LightDiscoverTxs s
-> BlockSummary IO (Either Address RewardAccount) ChainEvents
-> BlockData IO (Either Address RewardAccount) ChainEvents s
forall (m :: * -> *) addr tx s.
DiscoverTxs addr tx s
-> BlockSummary m addr tx -> BlockData m addr tx s
Summary LightDiscoverTxs s
discover)
                , ChainPoint -> IO ChainPoint
rollBackward :: ChainPoint -> IO ChainPoint
rollBackward :: ChainPoint -> IO ChainPoint
rollBackward
                }
        (Maybe (LightDiscoverTxs s)
_,Maybe
  (ChainFollower IO ChainPoint BlockHeader (LightBlocks IO Block)
   -> IO ())
_) -> -- light-mode not available
            NetworkLayer IO Block
-> Tracer IO ChainFollowLog
-> ChainFollower IO ChainPoint BlockHeader (NonEmpty Block)
-> IO ()
forall (m :: * -> *) block.
NetworkLayer m block
-> Tracer IO ChainFollowLog
-> ChainFollower m ChainPoint BlockHeader (NonEmpty block)
-> m ()
chainSync NetworkLayer IO Block
nw ((ChainFollowLog -> WalletWorkerLog)
-> Tracer IO WalletWorkerLog -> Tracer IO ChainFollowLog
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap ChainFollowLog -> WalletWorkerLog
MsgChainFollow Tracer IO WalletWorkerLog
tr) (ChainFollower IO ChainPoint BlockHeader (NonEmpty Block) -> IO ())
-> ChainFollower IO ChainPoint BlockHeader (NonEmpty Block)
-> IO ()
forall a b. (a -> b) -> a -> b
$ ChainFollower :: forall (m :: * -> *) point tip blocks.
(BlockHeight -> CheckpointPolicy)
-> m [point]
-> (blocks -> tip -> m ())
-> (point -> m point)
-> ChainFollower m point tip blocks
ChainFollower
                { BlockHeight -> CheckpointPolicy
checkpointPolicy :: BlockHeight -> CheckpointPolicy
checkpointPolicy :: BlockHeight -> CheckpointPolicy
checkpointPolicy
                , IO [ChainPoint]
readChainPoints :: IO [ChainPoint]
readChainPoints :: IO [ChainPoint]
readChainPoints
                , rollForward :: NonEmpty Block -> BlockHeader -> IO ()
rollForward = BlockData IO (Either Address RewardAccount) ChainEvents s
-> BlockHeader -> IO ()
rollForward' (BlockData IO (Either Address RewardAccount) ChainEvents s
 -> BlockHeader -> IO ())
-> (NonEmpty Block
    -> BlockData IO (Either Address RewardAccount) ChainEvents s)
-> NonEmpty Block
-> BlockHeader
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Block
-> BlockData IO (Either Address RewardAccount) ChainEvents s
forall (m :: * -> *) addr tx s.
NonEmpty Block -> BlockData m addr tx s
List
                , ChainPoint -> IO ChainPoint
rollBackward :: ChainPoint -> IO ChainPoint
rollBackward :: ChainPoint -> IO ChainPoint
rollBackward
                }
  where
    db :: DBLayer IO s k
db = ctx
ctx ctx
-> ((DBLayer IO s k -> Const (DBLayer IO s k) (DBLayer IO s k))
    -> ctx -> Const (DBLayer IO s k) ctx)
-> DBLayer IO s k
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx. HasDBLayer IO s k ctx => Lens' ctx (DBLayer IO s k)
forall (m :: * -> *) s (k :: Depth -> * -> *) ctx.
HasDBLayer m s k ctx =>
Lens' ctx (DBLayer m s k)
dbLayer @IO @s @k
    nw :: NetworkLayer IO Block
nw = ctx
ctx ctx
-> ((NetworkLayer IO Block
     -> Const (NetworkLayer IO Block) (NetworkLayer IO Block))
    -> ctx -> Const (NetworkLayer IO Block) ctx)
-> NetworkLayer IO Block
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx.
HasNetworkLayer IO ctx =>
Lens' ctx (NetworkLayer IO Block)
forall (m :: * -> *) ctx.
HasNetworkLayer m ctx =>
Lens' ctx (NetworkLayer m Block)
networkLayer @IO
    tr :: Tracer IO WalletWorkerLog
tr = ctx
ctx ctx
-> ((Tracer IO WalletWorkerLog
     -> Const (Tracer IO WalletWorkerLog) (Tracer IO WalletWorkerLog))
    -> ctx -> Const (Tracer IO WalletWorkerLog) ctx)
-> Tracer IO WalletWorkerLog
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx.
HasLogger IO WalletWorkerLog ctx =>
Lens' ctx (Tracer IO WalletWorkerLog)
forall (m :: * -> *) msg ctx.
HasLogger m msg ctx =>
Lens' ctx (Tracer m msg)
logger @_ @WalletWorkerLog

    -- See Note [CheckedExceptionsAndCallbacks]
    throwInIO :: ExceptT ErrNoSuchWallet IO a -> IO a
    throwInIO :: ExceptT ErrNoSuchWallet IO a -> IO a
throwInIO ExceptT ErrNoSuchWallet IO a
x = ExceptT ErrNoSuchWallet IO a -> IO (Either ErrNoSuchWallet a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT ErrNoSuchWallet IO a
x IO (Either ErrNoSuchWallet a)
-> (Either ErrNoSuchWallet a -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Right a
a -> a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
        Left  ErrNoSuchWallet
e -> UncheckErrNoSuchWallet -> IO a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (UncheckErrNoSuchWallet -> IO a) -> UncheckErrNoSuchWallet -> IO a
forall a b. (a -> b) -> a -> b
$ ErrNoSuchWallet -> UncheckErrNoSuchWallet
UncheckErrNoSuchWallet ErrNoSuchWallet
e

    catchFromIO :: IO a -> ExceptT ErrNoSuchWallet IO a
    catchFromIO :: IO a -> ExceptT ErrNoSuchWallet IO a
catchFromIO IO a
m = IO (Either ErrNoSuchWallet a) -> ExceptT ErrNoSuchWallet IO a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ErrNoSuchWallet a) -> ExceptT ErrNoSuchWallet IO a)
-> IO (Either ErrNoSuchWallet a) -> ExceptT ErrNoSuchWallet IO a
forall a b. (a -> b) -> a -> b
$
        (a -> Either ErrNoSuchWallet a
forall a b. b -> Either a b
Right (a -> Either ErrNoSuchWallet a)
-> IO a -> IO (Either ErrNoSuchWallet a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
m) IO (Either ErrNoSuchWallet a)
-> (UncheckErrNoSuchWallet -> IO (Either ErrNoSuchWallet a))
-> IO (Either ErrNoSuchWallet a)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (\(UncheckErrNoSuchWallet ErrNoSuchWallet
e) -> Either ErrNoSuchWallet a -> IO (Either ErrNoSuchWallet a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrNoSuchWallet a -> IO (Either ErrNoSuchWallet a))
-> Either ErrNoSuchWallet a -> IO (Either ErrNoSuchWallet a)
forall a b. (a -> b) -> a -> b
$ ErrNoSuchWallet -> Either ErrNoSuchWallet a
forall a b. a -> Either a b
Left ErrNoSuchWallet
e)

newtype UncheckErrNoSuchWallet = UncheckErrNoSuchWallet ErrNoSuchWallet
    deriving (UncheckErrNoSuchWallet -> UncheckErrNoSuchWallet -> Bool
(UncheckErrNoSuchWallet -> UncheckErrNoSuchWallet -> Bool)
-> (UncheckErrNoSuchWallet -> UncheckErrNoSuchWallet -> Bool)
-> Eq UncheckErrNoSuchWallet
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UncheckErrNoSuchWallet -> UncheckErrNoSuchWallet -> Bool
$c/= :: UncheckErrNoSuchWallet -> UncheckErrNoSuchWallet -> Bool
== :: UncheckErrNoSuchWallet -> UncheckErrNoSuchWallet -> Bool
$c== :: UncheckErrNoSuchWallet -> UncheckErrNoSuchWallet -> Bool
Eq, Int -> UncheckErrNoSuchWallet -> ShowS
[UncheckErrNoSuchWallet] -> ShowS
UncheckErrNoSuchWallet -> String
(Int -> UncheckErrNoSuchWallet -> ShowS)
-> (UncheckErrNoSuchWallet -> String)
-> ([UncheckErrNoSuchWallet] -> ShowS)
-> Show UncheckErrNoSuchWallet
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UncheckErrNoSuchWallet] -> ShowS
$cshowList :: [UncheckErrNoSuchWallet] -> ShowS
show :: UncheckErrNoSuchWallet -> String
$cshow :: UncheckErrNoSuchWallet -> String
showsPrec :: Int -> UncheckErrNoSuchWallet -> ShowS
$cshowsPrec :: Int -> UncheckErrNoSuchWallet -> ShowS
Show)
instance Exception UncheckErrNoSuchWallet

{- NOTE [CheckedExceptionsAndCallbacks]

Callback functions (such as the fields of 'ChainFollower')
may throw exceptions. Such exceptions typically cause the thread
(such as 'chainSync') which calls the callbacks to exit and
to return control to its parent.

Ideally, we would like these exceptions to be \"checked exceptions\",
which means that they are visible on the type level.
In our codebase, we (should) make sure that exceptions which are checked
cannot be instances of the 'Exception' class -- in this way,
it is statically guaranteed that they cannot be thrown in the 'IO' monad.

On the flip side, visibility on the type level does imply that
the calling thread (here 'chainSync') needs to be either polymorphic
in the checked exceptions or aware of them.
Making 'chainSync' aware of the checked exception is currently
not a good idea, because this function is used in different contexts,
which have different checked exceptions.
So, it would need to be polymorphic in the underlying monad,
but at present, 'chainSync' is restricted to 'IO' because some
of its constituents are also restricted to 'IO'.

As a workaround / solution, we wrap the checked exception into a new type
which can be thrown in the 'IO' monad.
When the calling thread exits, we catch the exception again
and present it as a checked exception.

-}

-- | Rewind the UTxO snapshots, transaction history and other information to a
-- the earliest point in the past that is before or is the point of rollback.
rollbackBlocks
    :: forall ctx s k.
        ( HasDBLayer IO s k ctx
        )
    => ctx
    -> WalletId
    -> Slot
    -> ExceptT ErrNoSuchWallet IO ChainPoint
rollbackBlocks :: ctx -> WalletId -> Slot -> ExceptT ErrNoSuchWallet IO ChainPoint
rollbackBlocks ctx
ctx WalletId
wid Slot
point = DBLayer IO s k
db DBLayer IO s k
-> (DBLayer IO s k -> ExceptT ErrNoSuchWallet IO ChainPoint)
-> ExceptT ErrNoSuchWallet IO ChainPoint
forall a b. a -> (a -> b) -> b
& \DBLayer{stm [WalletId]
DBVar stm (DeltaMap WalletId (DeltaWalletState s))
WalletId -> stm [LocalTxSubmissionStatus SealedTx]
WalletId -> stm [ChainPoint]
WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
WalletId -> stm (Maybe GenesisParameters)
WalletId -> stm (Maybe WalletMetadata)
WalletId -> stm (Maybe (Wallet s))
WalletId -> stm Coin
WalletId -> ExceptT ErrNoSuchWallet stm Bool
WalletId -> ExceptT ErrNoSuchWallet stm ()
WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
forall a. stm a -> IO a
atomically :: forall a. stm a -> IO a
prune :: WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
rollbackTo :: WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
readGenesisParameters :: WalletId -> stm (Maybe GenesisParameters)
readPrivateKey :: WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
putPrivateKey :: WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
removePendingOrExpiredTx :: WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
updatePendingTxForExpiry :: WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
readLocalTxSubmissionPending :: WalletId -> stm [LocalTxSubmissionStatus SealedTx]
putLocalTxSubmission :: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
getTx :: WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
readTxHistory :: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
putTxHistory :: WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
readDelegationRewardBalance :: WalletId -> stm Coin
putDelegationRewardBalance :: WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
putDelegationCertificate :: WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
isStakeKeyRegistered :: WalletId -> ExceptT ErrNoSuchWallet stm Bool
readWalletMeta :: WalletId -> stm (Maybe WalletMetadata)
putWalletMeta :: WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
listCheckpoints :: WalletId -> stm [ChainPoint]
readCheckpoint :: WalletId -> stm (Maybe (Wallet s))
putCheckpoint :: WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
walletsDB :: DBVar stm (DeltaMap WalletId (DeltaWalletState s))
listWallets :: stm [WalletId]
removeWallet :: WalletId -> ExceptT ErrNoSuchWallet stm ()
initializeWallet :: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
atomically :: ()
prune :: ()
rollbackTo :: ()
readGenesisParameters :: ()
readPrivateKey :: ()
putPrivateKey :: ()
removePendingOrExpiredTx :: ()
updatePendingTxForExpiry :: ()
readLocalTxSubmissionPending :: ()
putLocalTxSubmission :: ()
getTx :: ()
readTxHistory :: ()
putTxHistory :: ()
readDelegationRewardBalance :: ()
putDelegationRewardBalance :: ()
putDelegationCertificate :: ()
isStakeKeyRegistered :: ()
readWalletMeta :: ()
putWalletMeta :: ()
listCheckpoints :: ()
readCheckpoint :: ()
putCheckpoint :: ()
walletsDB :: ()
listWallets :: ()
removeWallet :: ()
initializeWallet :: ()
..} -> do
    (stm (Either ErrNoSuchWallet ChainPoint)
 -> IO (Either ErrNoSuchWallet ChainPoint))
-> ExceptT ErrNoSuchWallet stm ChainPoint
-> ExceptT ErrNoSuchWallet IO ChainPoint
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT stm (Either ErrNoSuchWallet ChainPoint)
-> IO (Either ErrNoSuchWallet ChainPoint)
forall a. stm a -> IO a
atomically (ExceptT ErrNoSuchWallet stm ChainPoint
 -> ExceptT ErrNoSuchWallet IO ChainPoint)
-> ExceptT ErrNoSuchWallet stm ChainPoint
-> ExceptT ErrNoSuchWallet IO ChainPoint
forall a b. (a -> b) -> a -> b
$ WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
rollbackTo WalletId
wid Slot
point
  where
    db :: DBLayer IO s k
db = ctx
ctx ctx
-> ((DBLayer IO s k -> Const (DBLayer IO s k) (DBLayer IO s k))
    -> ctx -> Const (DBLayer IO s k) ctx)
-> DBLayer IO s k
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx. HasDBLayer IO s k ctx => Lens' ctx (DBLayer IO s k)
forall (m :: * -> *) s (k :: Depth -> * -> *) ctx.
HasDBLayer m s k ctx =>
Lens' ctx (DBLayer m s k)
dbLayer @IO @s @k

-- | Apply the given blocks to the wallet and update the wallet state,
-- transaction history and corresponding metadata.
--
-- Concurrency: `restoreBlocks` is not atomic; we assume that
-- it is called in a sequential fashion for each wallet.
restoreBlocks
    :: forall ctx s k.
        ( HasDBLayer IO s k ctx
        , HasNetworkLayer IO ctx
        , IsOurs s Address
        , IsOurs s RewardAccount
        , AddressBookIso s
        )
    => ctx
    -> Tracer IO WalletFollowLog
    -> WalletId
    -> BlockData IO (Either Address RewardAccount) ChainEvents s
    -> BlockHeader
    -> ExceptT ErrNoSuchWallet IO ()
restoreBlocks :: ctx
-> Tracer IO WalletFollowLog
-> WalletId
-> BlockData IO (Either Address RewardAccount) ChainEvents s
-> BlockHeader
-> ExceptT ErrNoSuchWallet IO ()
restoreBlocks ctx
ctx Tracer IO WalletFollowLog
tr WalletId
wid BlockData IO (Either Address RewardAccount) ChainEvents s
blocks BlockHeader
nodeTip = DBLayer IO s k
db DBLayer IO s k
-> (DBLayer IO s k -> ExceptT ErrNoSuchWallet IO ())
-> ExceptT ErrNoSuchWallet IO ()
forall a b. a -> (a -> b) -> b
& \DBLayer{stm [WalletId]
DBVar stm (DeltaMap WalletId (DeltaWalletState s))
WalletId -> stm [LocalTxSubmissionStatus SealedTx]
WalletId -> stm [ChainPoint]
WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
WalletId -> stm (Maybe GenesisParameters)
WalletId -> stm (Maybe WalletMetadata)
WalletId -> stm (Maybe (Wallet s))
WalletId -> stm Coin
WalletId -> ExceptT ErrNoSuchWallet stm Bool
WalletId -> ExceptT ErrNoSuchWallet stm ()
WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
forall a. stm a -> IO a
atomically :: forall a. stm a -> IO a
prune :: WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
rollbackTo :: WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
readGenesisParameters :: WalletId -> stm (Maybe GenesisParameters)
readPrivateKey :: WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
putPrivateKey :: WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
removePendingOrExpiredTx :: WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
updatePendingTxForExpiry :: WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
readLocalTxSubmissionPending :: WalletId -> stm [LocalTxSubmissionStatus SealedTx]
putLocalTxSubmission :: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
getTx :: WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
readTxHistory :: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
putTxHistory :: WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
readDelegationRewardBalance :: WalletId -> stm Coin
putDelegationRewardBalance :: WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
putDelegationCertificate :: WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
isStakeKeyRegistered :: WalletId -> ExceptT ErrNoSuchWallet stm Bool
readWalletMeta :: WalletId -> stm (Maybe WalletMetadata)
putWalletMeta :: WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
listCheckpoints :: WalletId -> stm [ChainPoint]
readCheckpoint :: WalletId -> stm (Maybe (Wallet s))
putCheckpoint :: WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
walletsDB :: DBVar stm (DeltaMap WalletId (DeltaWalletState s))
listWallets :: stm [WalletId]
removeWallet :: WalletId -> ExceptT ErrNoSuchWallet stm ()
initializeWallet :: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
atomically :: ()
prune :: ()
rollbackTo :: ()
readGenesisParameters :: ()
readPrivateKey :: ()
putPrivateKey :: ()
removePendingOrExpiredTx :: ()
updatePendingTxForExpiry :: ()
readLocalTxSubmissionPending :: ()
putLocalTxSubmission :: ()
getTx :: ()
readTxHistory :: ()
putTxHistory :: ()
readDelegationRewardBalance :: ()
putDelegationRewardBalance :: ()
putDelegationCertificate :: ()
isStakeKeyRegistered :: ()
readWalletMeta :: ()
putWalletMeta :: ()
listCheckpoints :: ()
readCheckpoint :: ()
putCheckpoint :: ()
walletsDB :: ()
listWallets :: ()
removeWallet :: ()
initializeWallet :: ()
..} -> do
    SlottingParameters
sp  <- IO SlottingParameters
-> ExceptT ErrNoSuchWallet IO SlottingParameters
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SlottingParameters
 -> ExceptT ErrNoSuchWallet IO SlottingParameters)
-> IO SlottingParameters
-> ExceptT ErrNoSuchWallet IO SlottingParameters
forall a b. (a -> b) -> a -> b
$ NetworkLayer IO Block -> IO SlottingParameters
forall (m :: * -> *) block.
NetworkLayer m block -> m SlottingParameters
currentSlottingParameters NetworkLayer IO Block
nl
    Wallet s
cp0 <- (stm (Either ErrNoSuchWallet (Wallet s))
 -> IO (Either ErrNoSuchWallet (Wallet s)))
-> ExceptT ErrNoSuchWallet stm (Wallet s)
-> ExceptT ErrNoSuchWallet IO (Wallet s)
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT stm (Either ErrNoSuchWallet (Wallet s))
-> IO (Either ErrNoSuchWallet (Wallet s))
forall a. stm a -> IO a
atomically (ExceptT ErrNoSuchWallet stm (Wallet s)
 -> ExceptT ErrNoSuchWallet IO (Wallet s))
-> ExceptT ErrNoSuchWallet stm (Wallet s)
-> ExceptT ErrNoSuchWallet IO (Wallet s)
forall a b. (a -> b) -> a -> b
$
        WalletId
-> stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s)
forall (m :: * -> *) a.
Monad m =>
WalletId -> m (Maybe a) -> ExceptT ErrNoSuchWallet m a
withNoSuchWallet WalletId
wid (WalletId -> stm (Maybe (Wallet s))
readCheckpoint WalletId
wid)
    Bool
-> ExceptT ErrNoSuchWallet IO () -> ExceptT ErrNoSuchWallet IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Wallet s
cp0 Wallet s -> BlockHeader -> Bool
`isParentOf` BlockData IO (Either Address RewardAccount) ChainEvents s
-> BlockHeader
forall (m :: * -> *) addr txs s.
BlockData m addr txs s -> BlockHeader
firstHeader BlockData IO (Either Address RewardAccount) ChainEvents s
blocks) (ExceptT ErrNoSuchWallet IO () -> ExceptT ErrNoSuchWallet IO ())
-> ExceptT ErrNoSuchWallet IO () -> ExceptT ErrNoSuchWallet IO ()
forall a b. (a -> b) -> a -> b
$ String -> ExceptT ErrNoSuchWallet IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ExceptT ErrNoSuchWallet IO ())
-> String -> ExceptT ErrNoSuchWallet IO ()
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unwords
        [ Text
"restoreBlocks: given chain isn't a valid continuation."
        , Text
"Wallet is at:", BlockHeader -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty (Wallet s -> BlockHeader
forall s. Wallet s -> BlockHeader
currentTip Wallet s
cp0)
        , Text
"but the given chain continues starting from:"
        , BlockHeader -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty (BlockData IO (Either Address RewardAccount) ChainEvents s
-> BlockHeader
forall (m :: * -> *) addr txs s.
BlockData m addr txs s -> BlockHeader
firstHeader BlockData IO (Either Address RewardAccount) ChainEvents s
blocks)
        ]

    -- NOTE on concurrency:
    -- In light-mode, 'applyBlocks' may take some time to retrieve
    -- transaction data. We avoid blocking the database by
    -- not wrapping this into a call to 'atomically'.
    -- However, this only works if the latest database checkpoint, `cp0`,
    -- does not change in the meantime.
    (NonEmpty [FilteredBlock]
filteredBlocks', NonEmpty (DeltaWallet s, Wallet s)
cps') <- IO (NonEmpty [FilteredBlock], NonEmpty (DeltaWallet s, Wallet s))
-> ExceptT
     ErrNoSuchWallet
     IO
     (NonEmpty [FilteredBlock], NonEmpty (DeltaWallet s, Wallet s))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (NonEmpty [FilteredBlock], NonEmpty (DeltaWallet s, Wallet s))
 -> ExceptT
      ErrNoSuchWallet
      IO
      (NonEmpty [FilteredBlock], NonEmpty (DeltaWallet s, Wallet s)))
-> IO
     (NonEmpty [FilteredBlock], NonEmpty (DeltaWallet s, Wallet s))
-> ExceptT
     ErrNoSuchWallet
     IO
     (NonEmpty [FilteredBlock], NonEmpty (DeltaWallet s, Wallet s))
forall a b. (a -> b) -> a -> b
$ NonEmpty ([FilteredBlock], (DeltaWallet s, Wallet s))
-> (NonEmpty [FilteredBlock], NonEmpty (DeltaWallet s, Wallet s))
forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
NE.unzip (NonEmpty ([FilteredBlock], (DeltaWallet s, Wallet s))
 -> (NonEmpty [FilteredBlock], NonEmpty (DeltaWallet s, Wallet s)))
-> IO (NonEmpty ([FilteredBlock], (DeltaWallet s, Wallet s)))
-> IO
     (NonEmpty [FilteredBlock], NonEmpty (DeltaWallet s, Wallet s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockData IO (Either Address RewardAccount) ChainEvents s
-> Wallet s
-> IO (NonEmpty ([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 (NonEmpty ([FilteredBlock], (DeltaWallet s, Wallet s)))
applyBlocks @s BlockData IO (Either Address RewardAccount) ChainEvents s
blocks Wallet s
cp0
    let cps :: NonEmpty (Wallet s)
cps = ((DeltaWallet s, Wallet s) -> Wallet s)
-> NonEmpty (DeltaWallet s, Wallet s) -> NonEmpty (Wallet s)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (DeltaWallet s, Wallet s) -> Wallet s
forall a b. (a, b) -> b
snd NonEmpty (DeltaWallet s, Wallet s)
cps'
        filteredBlocks :: [FilteredBlock]
filteredBlocks = NonEmpty [FilteredBlock] -> [FilteredBlock]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat NonEmpty [FilteredBlock]
filteredBlocks'
    let slotPoolDelegations :: [(SlotNo, DelegationCertificate)]
slotPoolDelegations =
            [ (Slot -> SlotNo
forall p. Num p => WithOrigin p -> p
pseudoSlotNo (FilteredBlock
fblock FilteredBlock
-> ((Slot -> Const Slot Slot)
    -> FilteredBlock -> Const Slot FilteredBlock)
-> Slot
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "slot"
  ((Slot -> Const Slot Slot)
   -> FilteredBlock -> Const Slot FilteredBlock)
(Slot -> Const Slot Slot)
-> FilteredBlock -> Const Slot FilteredBlock
#slot), DelegationCertificate
cert)
            | FilteredBlock
fblock <- [FilteredBlock]
filteredBlocks
            , DelegationCertificate
cert <- (([DelegationCertificate]
  -> Const [DelegationCertificate] [DelegationCertificate])
 -> FilteredBlock -> Const [DelegationCertificate] FilteredBlock)
-> FilteredBlock -> [DelegationCertificate]
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "delegations"
  (([DelegationCertificate]
    -> Const [DelegationCertificate] [DelegationCertificate])
   -> FilteredBlock -> Const [DelegationCertificate] FilteredBlock)
([DelegationCertificate]
 -> Const [DelegationCertificate] [DelegationCertificate])
-> FilteredBlock -> Const [DelegationCertificate] FilteredBlock
#delegations FilteredBlock
fblock
            ]
        pseudoSlotNo :: WithOrigin p -> p
pseudoSlotNo WithOrigin p
Origin = p
0
        pseudoSlotNo (At p
sl) = p
sl
    let txs :: [(Tx, TxMeta)]
txs = [[(Tx, TxMeta)]] -> [(Tx, TxMeta)]
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([[(Tx, TxMeta)]] -> [(Tx, TxMeta)])
-> [[(Tx, TxMeta)]] -> [(Tx, TxMeta)]
forall a b. (a -> b) -> a -> b
$ (([(Tx, TxMeta)] -> Const [(Tx, TxMeta)] [(Tx, TxMeta)])
 -> FilteredBlock -> Const [(Tx, TxMeta)] FilteredBlock)
-> FilteredBlock -> [(Tx, TxMeta)]
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "transactions"
  (([(Tx, TxMeta)] -> Const [(Tx, TxMeta)] [(Tx, TxMeta)])
   -> FilteredBlock -> Const [(Tx, TxMeta)] FilteredBlock)
([(Tx, TxMeta)] -> Const [(Tx, TxMeta)] [(Tx, TxMeta)])
-> FilteredBlock -> Const [(Tx, TxMeta)] FilteredBlock
#transactions (FilteredBlock -> [(Tx, TxMeta)])
-> [FilteredBlock] -> [[(Tx, TxMeta)]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FilteredBlock]
filteredBlocks
    let epochStability :: Quantity "block" Word32
epochStability = (Word32
3Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
*) (Word32 -> Word32)
-> Quantity "block" Word32 -> Quantity "block" Word32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SlottingParameters -> Quantity "block" Word32
getSecurityParameter SlottingParameters
sp
    let localTip :: BlockHeader
localTip = Wallet s -> BlockHeader
forall s. Wallet s -> BlockHeader
currentTip (Wallet s -> BlockHeader) -> Wallet s -> BlockHeader
forall a b. (a -> b) -> a -> b
$ NonEmpty (Wallet s) -> Wallet s
forall a. NonEmpty a -> a
NE.last NonEmpty (Wallet s)
cps

    -- FIXME LATER during ADP-1403
    -- We need to rethink checkpoint creation and consider the case
    -- where the blocks are given as a 'Summary' and not a full 'List'
    -- of blocks. In this case, it could happen that the current
    -- scheme fails to create sufficiently many checkpoint as
    -- it was never able to touch the corresponding block.
    -- For now, we avoid this situation by being always supplied a 'List'
    -- in the unstable region close to the tip.
    let unstable :: Set Word32
unstable = [Word32] -> Set Word32
forall a. Ord a => [a] -> Set a
Set.fromList ([Word32] -> Set Word32) -> [Word32] -> Set Word32
forall a b. (a -> b) -> a -> b
$ SparseCheckpointsConfig -> Quantity "block" Word32 -> [Word32]
sparseCheckpoints SparseCheckpointsConfig
cfg (BlockHeader
nodeTip BlockHeader
-> ((Quantity "block" Word32
     -> Const (Quantity "block" Word32) (Quantity "block" Word32))
    -> BlockHeader -> Const (Quantity "block" Word32) BlockHeader)
-> Quantity "block" Word32
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "blockHeight"
  ((Quantity "block" Word32
    -> Const (Quantity "block" Word32) (Quantity "block" Word32))
   -> BlockHeader -> Const (Quantity "block" Word32) BlockHeader)
(Quantity "block" Word32
 -> Const (Quantity "block" Word32) (Quantity "block" Word32))
-> BlockHeader -> Const (Quantity "block" Word32) BlockHeader
#blockHeight)
            where
                -- NOTE
                -- The edge really is an optimization to avoid rolling back too
                -- "far" in the past. Yet, we let the edge construct itself
                -- organically once we reach the tip of the chain and start
                -- processing blocks one by one.
                --
                -- This prevents the wallet from trying to create too many
                -- checkpoints at once during restoration which causes massive
                -- performance degradation on large wallets.
                --
                -- Rollback may still occur during this short period, but
                -- rolling back from a few hundred blocks is relatively fast
                -- anyway.
                cfg :: SparseCheckpointsConfig
cfg = (Quantity "block" Word32 -> SparseCheckpointsConfig
defaultSparseCheckpointsConfig Quantity "block" Word32
epochStability) { edgeSize :: Word8
edgeSize = Word8
0 }

        getBlockHeight :: s -> b
getBlockHeight s
cp = a -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$
            s
cp s -> ((a -> Const a a) -> s -> Const a s) -> a
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel "currentTip" ((s -> Const a t) -> s -> Const a s)
(s -> Const a t) -> s -> Const a s
#currentTip ((s -> Const a t) -> s -> Const a s)
-> ((a -> Const a a) -> s -> Const a t)
-> (a -> Const a a)
-> s
-> Const a s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IsLabel "blockHeight" ((s -> Const a t) -> s -> Const a t)
(s -> Const a t) -> s -> Const a t
#blockHeight ((s -> Const a t) -> s -> Const a t)
-> ((a -> Const a a) -> s -> Const a t)
-> (a -> Const a a)
-> s
-> Const a t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IsLabel "getQuantity" ((a -> Const a a) -> s -> Const a t)
(a -> Const a a) -> s -> Const a t
#getQuantity
        willKeep :: Wallet s -> Bool
willKeep Wallet s
cp = Wallet s -> Word32
forall a s t s t s b.
(Integral a, HasField "blockHeight" s t s t,
 HasField "currentTip" s s s t, HasField "getQuantity" s t a a,
 Num b) =>
s -> b
getBlockHeight Wallet s
cp Word32 -> Set Word32 -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Word32
unstable
        cpsKeep :: [Wallet s]
cpsKeep = (Wallet s -> Bool) -> [Wallet s] -> [Wallet s]
forall a. (a -> Bool) -> [a] -> [a]
filter Wallet s -> Bool
willKeep (NonEmpty (Wallet s) -> [Wallet s]
forall a. NonEmpty a -> [a]
NE.init NonEmpty (Wallet s)
cps) [Wallet s] -> [Wallet s] -> [Wallet s]
forall a. Semigroup a => a -> a -> a
<> [NonEmpty (Wallet s) -> Wallet s
forall a. NonEmpty a -> a
NE.last NonEmpty (Wallet s)
cps]

        -- NOTE: We have to update the 'Prologue' as well,
        -- as it can contain addresses for pending transactions,
        -- which are removed from the 'Prologue' once the
        -- transactions are accepted onto the chain and discovered.
        --
        -- I'm not so sure that the approach here is correct with
        -- respect to rollbacks, but it is functionally the same
        -- as the code that came before.
        deltaPrologue :: DeltaWalletState s
deltaPrologue =
            [ Prologue s -> DeltaWalletState1 s
forall s. Prologue s -> DeltaWalletState1 s
ReplacePrologue (Prologue s -> DeltaWalletState1 s)
-> Prologue s -> DeltaWalletState1 s
forall a b. (a -> b) -> a -> b
$ s -> Prologue s
forall s. AddressBookIso s => s -> Prologue s
getPrologue (s -> Prologue s) -> s -> Prologue s
forall a b. (a -> b) -> a -> b
$ Wallet s -> s
forall s. Wallet s -> s
getState (Wallet s -> s) -> Wallet s -> s
forall a b. (a -> b) -> a -> b
$ NonEmpty (Wallet s) -> Wallet s
forall a. NonEmpty a -> a
NE.last NonEmpty (Wallet s)
cps ]
        delta :: DeltaWalletState s
delta = DeltaWalletState s
deltaPrologue DeltaWalletState s -> DeltaWalletState s -> DeltaWalletState s
forall a. [a] -> [a] -> [a]
++ DeltaWalletState s -> DeltaWalletState s
forall a. [a] -> [a]
reverse
            [ DeltasCheckpoints (WalletCheckpoint s) -> DeltaWalletState1 s
forall s.
DeltasCheckpoints (WalletCheckpoint s) -> DeltaWalletState1 s
UpdateCheckpoints [ Slot -> WalletCheckpoint s -> DeltaCheckpoints (WalletCheckpoint s)
forall a. Slot -> a -> DeltaCheckpoints a
PutCheckpoint (WalletCheckpoint s -> Slot
forall s. WalletCheckpoint s -> Slot
getSlot WalletCheckpoint s
wcp) WalletCheckpoint s
wcp ]
            | WalletCheckpoint s
wcp <- (Wallet s -> WalletCheckpoint s)
-> [Wallet s] -> [WalletCheckpoint s]
forall a b. (a -> b) -> [a] -> [b]
map ((Prologue s, WalletCheckpoint s) -> WalletCheckpoint s
forall a b. (a, b) -> b
snd ((Prologue s, WalletCheckpoint s) -> WalletCheckpoint s)
-> (Wallet s -> (Prologue s, WalletCheckpoint s))
-> Wallet s
-> WalletCheckpoint s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Wallet s -> (Prologue s, WalletCheckpoint s)
forall s.
AddressBookIso s =>
Wallet s -> (Prologue s, WalletCheckpoint s)
fromWallet) [Wallet s]
cpsKeep
            ]

    (stm (Either ErrNoSuchWallet ()) -> IO (Either ErrNoSuchWallet ()))
-> ExceptT ErrNoSuchWallet stm () -> ExceptT ErrNoSuchWallet IO ()
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT stm (Either ErrNoSuchWallet ()) -> IO (Either ErrNoSuchWallet ())
forall a. stm a -> IO a
atomically (ExceptT ErrNoSuchWallet stm () -> ExceptT ErrNoSuchWallet IO ())
-> ExceptT ErrNoSuchWallet stm () -> ExceptT ErrNoSuchWallet IO ()
forall a b. (a -> b) -> a -> b
$ do
        WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
putTxHistory WalletId
wid [(Tx, TxMeta)]
txs
        WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
updatePendingTxForExpiry WalletId
wid (((SlotNo -> Const SlotNo SlotNo)
 -> BlockHeader -> Const SlotNo BlockHeader)
-> BlockHeader -> SlotNo
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "slotNo"
  ((SlotNo -> Const SlotNo SlotNo)
   -> BlockHeader -> Const SlotNo BlockHeader)
(SlotNo -> Const SlotNo SlotNo)
-> BlockHeader -> Const SlotNo BlockHeader
#slotNo BlockHeader
localTip)
        [(SlotNo, DelegationCertificate)]
-> ((SlotNo, DelegationCertificate)
    -> ExceptT ErrNoSuchWallet stm ())
-> ExceptT ErrNoSuchWallet stm ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(SlotNo, DelegationCertificate)]
slotPoolDelegations (((SlotNo, DelegationCertificate)
  -> ExceptT ErrNoSuchWallet stm ())
 -> ExceptT ErrNoSuchWallet stm ())
-> ((SlotNo, DelegationCertificate)
    -> ExceptT ErrNoSuchWallet stm ())
-> ExceptT ErrNoSuchWallet stm ()
forall a b. (a -> b) -> a -> b
$ \delegation :: (SlotNo, DelegationCertificate)
delegation@(SlotNo
slotNo, DelegationCertificate
cert) -> do
            IO () -> ExceptT ErrNoSuchWallet stm ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ErrNoSuchWallet stm ())
-> IO () -> ExceptT ErrNoSuchWallet stm ()
forall a b. (a -> b) -> a -> b
$ (SlotNo, DelegationCertificate) -> IO ()
logDelegation (SlotNo, DelegationCertificate)
delegation
            WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
putDelegationCertificate WalletId
wid DelegationCertificate
cert SlotNo
slotNo

        IO () -> ExceptT ErrNoSuchWallet stm ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ErrNoSuchWallet stm ())
-> IO () -> ExceptT ErrNoSuchWallet stm ()
forall a b. (a -> b) -> a -> b
$ (Wallet s -> IO ()) -> [Wallet s] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Wallet s -> IO ()
logCheckpoint [Wallet s]
cpsKeep
        stm (Either ErrNoSuchWallet ()) -> ExceptT ErrNoSuchWallet stm ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (stm (Either ErrNoSuchWallet ()) -> ExceptT ErrNoSuchWallet stm ())
-> stm (Either ErrNoSuchWallet ())
-> ExceptT ErrNoSuchWallet stm ()
forall a b. (a -> b) -> a -> b
$ DBVar stm (DeltaMap WalletId (DeltaWalletState s))
-> (Map WalletId (WalletState s)
    -> (Maybe (DeltaMap WalletId (DeltaWalletState s)),
        Either ErrNoSuchWallet ()))
-> stm (Either ErrNoSuchWallet ())
forall da (m :: * -> *) a b.
(Delta da, Monad m, a ~ Base da) =>
DBVar m da -> (a -> (Maybe da, b)) -> m b
modifyDBMaybe DBVar stm (DeltaMap WalletId (DeltaWalletState s))
walletsDB ((Map WalletId (WalletState s)
  -> (Maybe (DeltaMap WalletId (DeltaWalletState s)),
      Either ErrNoSuchWallet ()))
 -> stm (Either ErrNoSuchWallet ()))
-> (Map WalletId (WalletState s)
    -> (Maybe (DeltaMap WalletId (DeltaWalletState s)),
        Either ErrNoSuchWallet ()))
-> stm (Either ErrNoSuchWallet ())
forall a b. (a -> b) -> a -> b
$
            WalletId
-> (ErrNoSuchWallet -> ErrNoSuchWallet)
-> (WalletState s
    -> Either ErrNoSuchWallet (DeltaWalletState s, ()))
-> Map WalletId (WalletState s)
-> (Maybe (DeltaMap WalletId (DeltaWalletState s)),
    Either ErrNoSuchWallet ())
forall e w dw b.
WalletId
-> (ErrNoSuchWallet -> e)
-> (w -> Either e (dw, b))
-> Map WalletId w
-> (Maybe (DeltaMap WalletId dw), Either e b)
adjustNoSuchWallet WalletId
wid ErrNoSuchWallet -> ErrNoSuchWallet
forall a. a -> a
id ((WalletState s -> Either ErrNoSuchWallet (DeltaWalletState s, ()))
 -> Map WalletId (WalletState s)
 -> (Maybe (DeltaMap WalletId (DeltaWalletState s)),
     Either ErrNoSuchWallet ()))
-> (WalletState s
    -> Either ErrNoSuchWallet (DeltaWalletState s, ()))
-> Map WalletId (WalletState s)
-> (Maybe (DeltaMap WalletId (DeltaWalletState s)),
    Either ErrNoSuchWallet ())
forall a b. (a -> b) -> a -> b
$ \WalletState s
_ -> (DeltaWalletState s, ())
-> Either ErrNoSuchWallet (DeltaWalletState s, ())
forall a b. b -> Either a b
Right ( DeltaWalletState s
delta, () )

        WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
prune WalletId
wid Quantity "block" Word32
epochStability

        IO () -> ExceptT ErrNoSuchWallet stm ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ErrNoSuchWallet stm ())
-> IO () -> ExceptT ErrNoSuchWallet stm ()
forall a b. (a -> b) -> a -> b
$ do
            Tracer IO WalletFollowLog -> WalletFollowLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO WalletFollowLog
tr (WalletFollowLog -> IO ()) -> WalletFollowLog -> IO ()
forall a b. (a -> b) -> a -> b
$ [(Tx, TxMeta)] -> WalletFollowLog
MsgDiscoveredTxs [(Tx, TxMeta)]
txs
            Tracer IO WalletFollowLog -> WalletFollowLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO WalletFollowLog
tr (WalletFollowLog -> IO ()) -> WalletFollowLog -> IO ()
forall a b. (a -> b) -> a -> b
$ [(Tx, TxMeta)] -> WalletFollowLog
MsgDiscoveredTxsContent [(Tx, TxMeta)]
txs
  where
    nl :: NetworkLayer IO Block
nl = ctx
ctx ctx
-> ((NetworkLayer IO Block
     -> Const (NetworkLayer IO Block) (NetworkLayer IO Block))
    -> ctx -> Const (NetworkLayer IO Block) ctx)
-> NetworkLayer IO Block
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. (NetworkLayer IO Block
 -> Const (NetworkLayer IO Block) (NetworkLayer IO Block))
-> ctx -> Const (NetworkLayer IO Block) ctx
forall (m :: * -> *) ctx.
HasNetworkLayer m ctx =>
Lens' ctx (NetworkLayer m Block)
networkLayer
    db :: DBLayer IO s k
db = ctx
ctx ctx
-> ((DBLayer IO s k -> Const (DBLayer IO s k) (DBLayer IO s k))
    -> ctx -> Const (DBLayer IO s k) ctx)
-> DBLayer IO s k
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx. HasDBLayer IO s k ctx => Lens' ctx (DBLayer IO s k)
forall (m :: * -> *) s (k :: Depth -> * -> *) ctx.
HasDBLayer m s k ctx =>
Lens' ctx (DBLayer m s k)
dbLayer @IO @s @k

    logCheckpoint :: Wallet s -> IO ()
    logCheckpoint :: Wallet s -> IO ()
logCheckpoint Wallet s
cp = Tracer IO WalletFollowLog -> WalletFollowLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO WalletFollowLog
tr (WalletFollowLog -> IO ()) -> WalletFollowLog -> IO ()
forall a b. (a -> b) -> a -> b
$ BlockHeader -> WalletFollowLog
MsgCheckpoint (Wallet s -> BlockHeader
forall s. Wallet s -> BlockHeader
currentTip Wallet s
cp)

    logDelegation :: (SlotNo, DelegationCertificate) -> IO ()
    logDelegation :: (SlotNo, DelegationCertificate) -> IO ()
logDelegation = Tracer IO WalletFollowLog -> WalletFollowLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO WalletFollowLog
tr (WalletFollowLog -> IO ())
-> ((SlotNo, DelegationCertificate) -> WalletFollowLog)
-> (SlotNo, DelegationCertificate)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SlotNo -> DelegationCertificate -> WalletFollowLog)
-> (SlotNo, DelegationCertificate) -> WalletFollowLog
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry SlotNo -> DelegationCertificate -> WalletFollowLog
MsgDiscoveredDelegationCert

    isParentOf :: Wallet s -> BlockHeader -> Bool
    isParentOf :: Wallet s -> BlockHeader -> Bool
isParentOf Wallet s
cp = (Maybe (Hash "BlockHeader") -> Maybe (Hash "BlockHeader") -> Bool
forall a. Eq a => a -> a -> Bool
== Hash "BlockHeader" -> Maybe (Hash "BlockHeader")
forall a. a -> Maybe a
Just Hash "BlockHeader"
parent) (Maybe (Hash "BlockHeader") -> Bool)
-> (BlockHeader -> Maybe (Hash "BlockHeader"))
-> BlockHeader
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockHeader -> Maybe (Hash "BlockHeader")
parentHeaderHash
      where parent :: Hash "BlockHeader"
parent = BlockHeader -> Hash "BlockHeader"
headerHash (BlockHeader -> Hash "BlockHeader")
-> BlockHeader -> Hash "BlockHeader"
forall a b. (a -> b) -> a -> b
$ Wallet s -> BlockHeader
forall s. Wallet s -> BlockHeader
currentTip Wallet s
cp

-- | Remove an existing wallet. Note that there's no particular work to
-- be done regarding the restoration worker as it will simply terminate
-- on the next tick when noticing that the corresponding wallet is gone.
deleteWallet
    :: forall ctx s k.
        ( HasDBLayer IO s k ctx
        )
    => ctx
    -> WalletId
    -> ExceptT ErrNoSuchWallet IO ()
deleteWallet :: ctx -> WalletId -> ExceptT ErrNoSuchWallet IO ()
deleteWallet ctx
ctx WalletId
wid = DBLayer IO s k
db DBLayer IO s k
-> (DBLayer IO s k -> ExceptT ErrNoSuchWallet IO ())
-> ExceptT ErrNoSuchWallet IO ()
forall a b. a -> (a -> b) -> b
& \DBLayer{stm [WalletId]
DBVar stm (DeltaMap WalletId (DeltaWalletState s))
WalletId -> stm [LocalTxSubmissionStatus SealedTx]
WalletId -> stm [ChainPoint]
WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
WalletId -> stm (Maybe GenesisParameters)
WalletId -> stm (Maybe WalletMetadata)
WalletId -> stm (Maybe (Wallet s))
WalletId -> stm Coin
WalletId -> ExceptT ErrNoSuchWallet stm Bool
WalletId -> ExceptT ErrNoSuchWallet stm ()
WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
forall a. stm a -> IO a
atomically :: forall a. stm a -> IO a
prune :: WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
rollbackTo :: WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
readGenesisParameters :: WalletId -> stm (Maybe GenesisParameters)
readPrivateKey :: WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
putPrivateKey :: WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
removePendingOrExpiredTx :: WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
updatePendingTxForExpiry :: WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
readLocalTxSubmissionPending :: WalletId -> stm [LocalTxSubmissionStatus SealedTx]
putLocalTxSubmission :: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
getTx :: WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
readTxHistory :: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
putTxHistory :: WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
readDelegationRewardBalance :: WalletId -> stm Coin
putDelegationRewardBalance :: WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
putDelegationCertificate :: WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
isStakeKeyRegistered :: WalletId -> ExceptT ErrNoSuchWallet stm Bool
readWalletMeta :: WalletId -> stm (Maybe WalletMetadata)
putWalletMeta :: WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
listCheckpoints :: WalletId -> stm [ChainPoint]
readCheckpoint :: WalletId -> stm (Maybe (Wallet s))
putCheckpoint :: WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
walletsDB :: DBVar stm (DeltaMap WalletId (DeltaWalletState s))
listWallets :: stm [WalletId]
removeWallet :: WalletId -> ExceptT ErrNoSuchWallet stm ()
initializeWallet :: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
atomically :: ()
prune :: ()
rollbackTo :: ()
readGenesisParameters :: ()
readPrivateKey :: ()
putPrivateKey :: ()
removePendingOrExpiredTx :: ()
updatePendingTxForExpiry :: ()
readLocalTxSubmissionPending :: ()
putLocalTxSubmission :: ()
getTx :: ()
readTxHistory :: ()
putTxHistory :: ()
readDelegationRewardBalance :: ()
putDelegationRewardBalance :: ()
putDelegationCertificate :: ()
isStakeKeyRegistered :: ()
readWalletMeta :: ()
putWalletMeta :: ()
listCheckpoints :: ()
readCheckpoint :: ()
putCheckpoint :: ()
walletsDB :: ()
listWallets :: ()
removeWallet :: ()
initializeWallet :: ()
..} -> do
    (stm (Either ErrNoSuchWallet ()) -> IO (Either ErrNoSuchWallet ()))
-> ExceptT ErrNoSuchWallet stm () -> ExceptT ErrNoSuchWallet IO ()
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT stm (Either ErrNoSuchWallet ()) -> IO (Either ErrNoSuchWallet ())
forall a. stm a -> IO a
atomically (ExceptT ErrNoSuchWallet stm () -> ExceptT ErrNoSuchWallet IO ())
-> ExceptT ErrNoSuchWallet stm () -> ExceptT ErrNoSuchWallet IO ()
forall a b. (a -> b) -> a -> b
$ WalletId -> ExceptT ErrNoSuchWallet stm ()
removeWallet WalletId
wid
  where
    db :: DBLayer IO s k
db = ctx
ctx ctx
-> ((DBLayer IO s k -> Const (DBLayer IO s k) (DBLayer IO s k))
    -> ctx -> Const (DBLayer IO s k) ctx)
-> DBLayer IO s k
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx. HasDBLayer IO s k ctx => Lens' ctx (DBLayer IO s k)
forall (m :: * -> *) s (k :: Depth -> * -> *) ctx.
HasDBLayer m s k ctx =>
Lens' ctx (DBLayer m s k)
dbLayer @IO @s @k

-- | Fetch the cached reward balance of a given wallet from the database.
fetchRewardBalance
    :: forall ctx s k.
        ( HasDBLayer IO s k ctx
        )
    => ctx
    -> WalletId
    -> IO Coin
fetchRewardBalance :: ctx -> WalletId -> IO Coin
fetchRewardBalance ctx
ctx WalletId
wid = DBLayer IO s k
db DBLayer IO s k -> (DBLayer IO s k -> IO Coin) -> IO Coin
forall a b. a -> (a -> b) -> b
& \DBLayer{stm [WalletId]
DBVar stm (DeltaMap WalletId (DeltaWalletState s))
WalletId -> stm [LocalTxSubmissionStatus SealedTx]
WalletId -> stm [ChainPoint]
WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
WalletId -> stm (Maybe GenesisParameters)
WalletId -> stm (Maybe WalletMetadata)
WalletId -> stm (Maybe (Wallet s))
WalletId -> stm Coin
WalletId -> ExceptT ErrNoSuchWallet stm Bool
WalletId -> ExceptT ErrNoSuchWallet stm ()
WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
forall a. stm a -> IO a
atomically :: forall a. stm a -> IO a
prune :: WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
rollbackTo :: WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
readGenesisParameters :: WalletId -> stm (Maybe GenesisParameters)
readPrivateKey :: WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
putPrivateKey :: WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
removePendingOrExpiredTx :: WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
updatePendingTxForExpiry :: WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
readLocalTxSubmissionPending :: WalletId -> stm [LocalTxSubmissionStatus SealedTx]
putLocalTxSubmission :: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
getTx :: WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
readTxHistory :: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
putTxHistory :: WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
readDelegationRewardBalance :: WalletId -> stm Coin
putDelegationRewardBalance :: WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
putDelegationCertificate :: WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
isStakeKeyRegistered :: WalletId -> ExceptT ErrNoSuchWallet stm Bool
readWalletMeta :: WalletId -> stm (Maybe WalletMetadata)
putWalletMeta :: WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
listCheckpoints :: WalletId -> stm [ChainPoint]
readCheckpoint :: WalletId -> stm (Maybe (Wallet s))
putCheckpoint :: WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
walletsDB :: DBVar stm (DeltaMap WalletId (DeltaWalletState s))
listWallets :: stm [WalletId]
removeWallet :: WalletId -> ExceptT ErrNoSuchWallet stm ()
initializeWallet :: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
atomically :: ()
prune :: ()
rollbackTo :: ()
readGenesisParameters :: ()
readPrivateKey :: ()
putPrivateKey :: ()
removePendingOrExpiredTx :: ()
updatePendingTxForExpiry :: ()
readLocalTxSubmissionPending :: ()
putLocalTxSubmission :: ()
getTx :: ()
readTxHistory :: ()
putTxHistory :: ()
readDelegationRewardBalance :: ()
putDelegationRewardBalance :: ()
putDelegationCertificate :: ()
isStakeKeyRegistered :: ()
readWalletMeta :: ()
putWalletMeta :: ()
listCheckpoints :: ()
readCheckpoint :: ()
putCheckpoint :: ()
walletsDB :: ()
listWallets :: ()
removeWallet :: ()
initializeWallet :: ()
..} ->
    stm Coin -> IO Coin
forall a. stm a -> IO a
atomically (stm Coin -> IO Coin) -> stm Coin -> IO Coin
forall a b. (a -> b) -> a -> b
$ WalletId -> stm Coin
readDelegationRewardBalance WalletId
wid
  where
    db :: DBLayer IO s k
db = ctx
ctx ctx
-> ((DBLayer IO s k -> Const (DBLayer IO s k) (DBLayer IO s k))
    -> ctx -> Const (DBLayer IO s k) ctx)
-> DBLayer IO s k
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx. HasDBLayer IO s k ctx => Lens' ctx (DBLayer IO s k)
forall (m :: * -> *) s (k :: Depth -> * -> *) ctx.
HasDBLayer m s k ctx =>
Lens' ctx (DBLayer m s k)
dbLayer @IO @s @k

-- | Read the current withdrawal capacity of a wallet. Note that, this simply
-- returns 0 if:
--
-- a) There's no reward account for this type of wallet.
-- b) The current reward value is too small to be considered (adding it would
-- cost more than its value).
readNextWithdrawal
    :: forall ctx k.
        ( HasTransactionLayer k ctx
        , HasNetworkLayer IO ctx
        )
    => ctx
    -> Cardano.AnyCardanoEra
    -> Coin
    -> IO Coin
readNextWithdrawal :: ctx -> AnyCardanoEra -> Coin -> IO Coin
readNextWithdrawal ctx
ctx AnyCardanoEra
era (Coin Natural
withdrawal) = do
    ProtocolParameters
pp <- NetworkLayer IO Block -> IO ProtocolParameters
forall (m :: * -> *) block.
NetworkLayer m block -> m ProtocolParameters
currentProtocolParameters NetworkLayer IO Block
nl

    let costWith :: Coin
costWith =
            TransactionLayer k SealedTx
-> AnyCardanoEra
-> ProtocolParameters
-> TransactionCtx
-> SelectionSkeleton
-> Coin
forall (k :: Depth -> * -> *) tx.
TransactionLayer k tx
-> AnyCardanoEra
-> ProtocolParameters
-> TransactionCtx
-> SelectionSkeleton
-> Coin
calcMinimumCost TransactionLayer k SealedTx
tl AnyCardanoEra
era ProtocolParameters
pp (Coin -> TransactionCtx
mkTxCtx (Coin -> TransactionCtx) -> Coin -> TransactionCtx
forall a b. (a -> b) -> a -> b
$ Natural -> Coin
Coin Natural
withdrawal) SelectionSkeleton
emptySkeleton

    let costWithout :: Coin
costWithout =
            TransactionLayer k SealedTx
-> AnyCardanoEra
-> ProtocolParameters
-> TransactionCtx
-> SelectionSkeleton
-> Coin
forall (k :: Depth -> * -> *) tx.
TransactionLayer k tx
-> AnyCardanoEra
-> ProtocolParameters
-> TransactionCtx
-> SelectionSkeleton
-> Coin
calcMinimumCost TransactionLayer k SealedTx
tl AnyCardanoEra
era ProtocolParameters
pp (Coin -> TransactionCtx
mkTxCtx (Coin -> TransactionCtx) -> Coin -> TransactionCtx
forall a b. (a -> b) -> a -> b
$ Natural -> Coin
Coin Natural
0) SelectionSkeleton
emptySkeleton

    let costOfWithdrawal :: BlockHeight
costOfWithdrawal =
            Coin -> BlockHeight
Coin.toInteger Coin
costWith BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
- Coin -> BlockHeight
Coin.toInteger Coin
costWithout

    if Natural -> BlockHeight
forall a. Integral a => a -> BlockHeight
toInteger Natural
withdrawal BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
< BlockHeight
2 BlockHeight -> BlockHeight -> BlockHeight
forall a. Num a => a -> a -> a
* BlockHeight
costOfWithdrawal
    then Coin -> IO Coin
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Natural -> Coin
Coin Natural
0)
    else Coin -> IO Coin
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Natural -> Coin
Coin Natural
withdrawal)
  where
    tl :: TransactionLayer k SealedTx
tl = ctx
ctx ctx
-> ((TransactionLayer k SealedTx
     -> Const
          (TransactionLayer k SealedTx) (TransactionLayer k SealedTx))
    -> ctx -> Const (TransactionLayer k SealedTx) ctx)
-> TransactionLayer k SealedTx
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx.
HasTransactionLayer k ctx =>
Lens' ctx (TransactionLayer k SealedTx)
forall (k :: Depth -> * -> *) ctx.
HasTransactionLayer k ctx =>
Lens' ctx (TransactionLayer k SealedTx)
transactionLayer @k
    nl :: NetworkLayer IO Block
nl = ctx
ctx ctx
-> ((NetworkLayer IO Block
     -> Const (NetworkLayer IO Block) (NetworkLayer IO Block))
    -> ctx -> Const (NetworkLayer IO Block) ctx)
-> NetworkLayer IO Block
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. (NetworkLayer IO Block
 -> Const (NetworkLayer IO Block) (NetworkLayer IO Block))
-> ctx -> Const (NetworkLayer IO Block) ctx
forall (m :: * -> *) ctx.
HasNetworkLayer m ctx =>
Lens' ctx (NetworkLayer m Block)
networkLayer

    mkTxCtx :: Coin -> TransactionCtx
mkTxCtx Coin
wdrl = TransactionCtx
defaultTransactionCtx
        { $sel:txWithdrawal:TransactionCtx :: Withdrawal
txWithdrawal = RewardAccount -> NonEmpty DerivationIndex -> Coin -> Withdrawal
WithdrawalSelf RewardAccount
dummyAcct NonEmpty DerivationIndex
dummyPath Coin
wdrl }
      where
        dummyAcct :: RewardAccount
dummyAcct =
            ByteString -> RewardAccount
RewardAccount ByteString
forall a. Monoid a => a
mempty
        dummyPath :: NonEmpty DerivationIndex
dummyPath =
            Word32 -> DerivationIndex
DerivationIndex Word32
0 DerivationIndex -> [DerivationIndex] -> NonEmpty DerivationIndex
forall a. a -> [a] -> NonEmpty a
:| []

readRewardAccount
    :: forall ctx s k (n :: NetworkDiscriminant) shelley.
        ( HasDBLayer IO s k ctx
        , shelley ~ SeqState n ShelleyKey
        , Typeable n
        , Typeable s
        )
    => ctx
    -> WalletId
    -> ExceptT ErrReadRewardAccount IO (RewardAccount, XPub, NonEmpty DerivationIndex)
readRewardAccount :: ctx
-> WalletId
-> ExceptT
     ErrReadRewardAccount
     IO
     (RewardAccount, XPub, NonEmpty DerivationIndex)
readRewardAccount ctx
ctx WalletId
wid = DBLayer IO s k
db DBLayer IO s k
-> (DBLayer IO s k
    -> ExceptT
         ErrReadRewardAccount
         IO
         (RewardAccount, XPub, NonEmpty DerivationIndex))
-> ExceptT
     ErrReadRewardAccount
     IO
     (RewardAccount, XPub, NonEmpty DerivationIndex)
forall a b. a -> (a -> b) -> b
& \DBLayer{stm [WalletId]
DBVar stm (DeltaMap WalletId (DeltaWalletState s))
WalletId -> stm [LocalTxSubmissionStatus SealedTx]
WalletId -> stm [ChainPoint]
WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
WalletId -> stm (Maybe GenesisParameters)
WalletId -> stm (Maybe WalletMetadata)
WalletId -> stm (Maybe (Wallet s))
WalletId -> stm Coin
WalletId -> ExceptT ErrNoSuchWallet stm Bool
WalletId -> ExceptT ErrNoSuchWallet stm ()
WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
forall a. stm a -> IO a
atomically :: forall a. stm a -> IO a
prune :: WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
rollbackTo :: WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
readGenesisParameters :: WalletId -> stm (Maybe GenesisParameters)
readPrivateKey :: WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
putPrivateKey :: WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
removePendingOrExpiredTx :: WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
updatePendingTxForExpiry :: WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
readLocalTxSubmissionPending :: WalletId -> stm [LocalTxSubmissionStatus SealedTx]
putLocalTxSubmission :: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
getTx :: WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
readTxHistory :: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
putTxHistory :: WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
readDelegationRewardBalance :: WalletId -> stm Coin
putDelegationRewardBalance :: WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
putDelegationCertificate :: WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
isStakeKeyRegistered :: WalletId -> ExceptT ErrNoSuchWallet stm Bool
readWalletMeta :: WalletId -> stm (Maybe WalletMetadata)
putWalletMeta :: WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
listCheckpoints :: WalletId -> stm [ChainPoint]
readCheckpoint :: WalletId -> stm (Maybe (Wallet s))
putCheckpoint :: WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
walletsDB :: DBVar stm (DeltaMap WalletId (DeltaWalletState s))
listWallets :: stm [WalletId]
removeWallet :: WalletId -> ExceptT ErrNoSuchWallet stm ()
initializeWallet :: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
atomically :: ()
prune :: ()
rollbackTo :: ()
readGenesisParameters :: ()
readPrivateKey :: ()
putPrivateKey :: ()
removePendingOrExpiredTx :: ()
updatePendingTxForExpiry :: ()
readLocalTxSubmissionPending :: ()
putLocalTxSubmission :: ()
getTx :: ()
readTxHistory :: ()
putTxHistory :: ()
readDelegationRewardBalance :: ()
putDelegationRewardBalance :: ()
putDelegationCertificate :: ()
isStakeKeyRegistered :: ()
readWalletMeta :: ()
putWalletMeta :: ()
listCheckpoints :: ()
readCheckpoint :: ()
putCheckpoint :: ()
walletsDB :: ()
listWallets :: ()
removeWallet :: ()
initializeWallet :: ()
..} -> do
    Wallet s
cp <- (ErrNoSuchWallet -> ErrReadRewardAccount)
-> ExceptT ErrNoSuchWallet IO (Wallet s)
-> ExceptT ErrReadRewardAccount IO (Wallet s)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ErrNoSuchWallet -> ErrReadRewardAccount
ErrReadRewardAccountNoSuchWallet
        (ExceptT ErrNoSuchWallet IO (Wallet s)
 -> ExceptT ErrReadRewardAccount IO (Wallet s))
-> ExceptT ErrNoSuchWallet IO (Wallet s)
-> ExceptT ErrReadRewardAccount IO (Wallet s)
forall a b. (a -> b) -> a -> b
$ (stm (Either ErrNoSuchWallet (Wallet s))
 -> IO (Either ErrNoSuchWallet (Wallet s)))
-> ExceptT ErrNoSuchWallet stm (Wallet s)
-> ExceptT ErrNoSuchWallet IO (Wallet s)
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT stm (Either ErrNoSuchWallet (Wallet s))
-> IO (Either ErrNoSuchWallet (Wallet s))
forall a. stm a -> IO a
atomically
        (ExceptT ErrNoSuchWallet stm (Wallet s)
 -> ExceptT ErrNoSuchWallet IO (Wallet s))
-> ExceptT ErrNoSuchWallet stm (Wallet s)
-> ExceptT ErrNoSuchWallet IO (Wallet s)
forall a b. (a -> b) -> a -> b
$ WalletId
-> stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s)
forall (m :: * -> *) a.
Monad m =>
WalletId -> m (Maybe a) -> ExceptT ErrNoSuchWallet m a
withNoSuchWallet WalletId
wid
        (stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s))
-> stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s)
forall a b. (a -> b) -> a -> b
$ WalletId -> stm (Maybe (Wallet s))
readCheckpoint WalletId
wid
    case TypeRep s -> TypeRep shelley -> Maybe (s :~: shelley)
forall k (f :: k -> *) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality (Typeable s => TypeRep s
forall k (a :: k). Typeable a => TypeRep a
typeRep @s) (Typeable shelley => TypeRep shelley
forall k (a :: k). Typeable a => TypeRep a
typeRep @shelley) of
        Maybe (s :~: shelley)
Nothing ->
            ErrReadRewardAccount
-> ExceptT
     ErrReadRewardAccount
     IO
     (RewardAccount, XPub, NonEmpty DerivationIndex)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ErrReadRewardAccount
ErrReadRewardAccountNotAShelleyWallet
        Just s :~: shelley
Refl -> do
            let s :: s
s = Wallet s -> s
forall s. Wallet s -> s
getState Wallet s
cp
            let xpub :: ShelleyKey 'AddressK XPub
xpub = SeqState n ShelleyKey -> ShelleyKey 'AddressK XPub
forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
SeqState n k -> k 'AddressK XPub
Seq.rewardAccountKey s
SeqState n ShelleyKey
s
            let acct :: RewardAccount
acct = ShelleyKey 'AddressK XPub -> RewardAccount
forall (k :: Depth -> * -> *).
ToRewardAccount k =>
k 'AddressK XPub -> RewardAccount
toRewardAccount ShelleyKey 'AddressK XPub
xpub
            let path :: NonEmpty DerivationIndex
path = DerivationPrefix -> NonEmpty DerivationIndex
stakeDerivationPath (DerivationPrefix -> NonEmpty DerivationIndex)
-> DerivationPrefix -> NonEmpty DerivationIndex
forall a b. (a -> b) -> a -> b
$ SeqState n ShelleyKey -> DerivationPrefix
forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
SeqState n k -> DerivationPrefix
Seq.derivationPrefix s
SeqState n ShelleyKey
s
            (RewardAccount, XPub, NonEmpty DerivationIndex)
-> ExceptT
     ErrReadRewardAccount
     IO
     (RewardAccount, XPub, NonEmpty DerivationIndex)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RewardAccount
acct, ShelleyKey 'AddressK XPub -> XPub
forall (key :: Depth -> * -> *) (depth :: Depth) raw.
WalletKey key =>
key depth raw -> raw
getRawKey ShelleyKey 'AddressK XPub
xpub, NonEmpty DerivationIndex
path)
  where
    db :: DBLayer IO s k
db = ctx
ctx ctx
-> ((DBLayer IO s k -> Const (DBLayer IO s k) (DBLayer IO s k))
    -> ctx -> Const (DBLayer IO s k) ctx)
-> DBLayer IO s k
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx. HasDBLayer IO s k ctx => Lens' ctx (DBLayer IO s k)
forall (m :: * -> *) s (k :: Depth -> * -> *) ctx.
HasDBLayer m s k ctx =>
Lens' ctx (DBLayer m s k)
dbLayer @IO @s @k

readPolicyPublicKey
    :: forall ctx s k (n :: NetworkDiscriminant) shelley.
        ( HasDBLayer IO s k ctx
        , shelley ~ SeqState n ShelleyKey
        , Typeable n
        , Typeable s
        )
    => ctx
    -> WalletId
    -> ExceptT ErrReadPolicyPublicKey IO (XPub, NonEmpty DerivationIndex)
readPolicyPublicKey :: ctx
-> WalletId
-> ExceptT
     ErrReadPolicyPublicKey IO (XPub, NonEmpty DerivationIndex)
readPolicyPublicKey ctx
ctx WalletId
wid = DBLayer IO s k
db DBLayer IO s k
-> (DBLayer IO s k
    -> ExceptT
         ErrReadPolicyPublicKey IO (XPub, NonEmpty DerivationIndex))
-> ExceptT
     ErrReadPolicyPublicKey IO (XPub, NonEmpty DerivationIndex)
forall a b. a -> (a -> b) -> b
& \DBLayer{stm [WalletId]
DBVar stm (DeltaMap WalletId (DeltaWalletState s))
WalletId -> stm [LocalTxSubmissionStatus SealedTx]
WalletId -> stm [ChainPoint]
WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
WalletId -> stm (Maybe GenesisParameters)
WalletId -> stm (Maybe WalletMetadata)
WalletId -> stm (Maybe (Wallet s))
WalletId -> stm Coin
WalletId -> ExceptT ErrNoSuchWallet stm Bool
WalletId -> ExceptT ErrNoSuchWallet stm ()
WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
forall a. stm a -> IO a
atomically :: forall a. stm a -> IO a
prune :: WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
rollbackTo :: WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
readGenesisParameters :: WalletId -> stm (Maybe GenesisParameters)
readPrivateKey :: WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
putPrivateKey :: WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
removePendingOrExpiredTx :: WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
updatePendingTxForExpiry :: WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
readLocalTxSubmissionPending :: WalletId -> stm [LocalTxSubmissionStatus SealedTx]
putLocalTxSubmission :: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
getTx :: WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
readTxHistory :: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
putTxHistory :: WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
readDelegationRewardBalance :: WalletId -> stm Coin
putDelegationRewardBalance :: WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
putDelegationCertificate :: WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
isStakeKeyRegistered :: WalletId -> ExceptT ErrNoSuchWallet stm Bool
readWalletMeta :: WalletId -> stm (Maybe WalletMetadata)
putWalletMeta :: WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
listCheckpoints :: WalletId -> stm [ChainPoint]
readCheckpoint :: WalletId -> stm (Maybe (Wallet s))
putCheckpoint :: WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
walletsDB :: DBVar stm (DeltaMap WalletId (DeltaWalletState s))
listWallets :: stm [WalletId]
removeWallet :: WalletId -> ExceptT ErrNoSuchWallet stm ()
initializeWallet :: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
atomically :: ()
prune :: ()
rollbackTo :: ()
readGenesisParameters :: ()
readPrivateKey :: ()
putPrivateKey :: ()
removePendingOrExpiredTx :: ()
updatePendingTxForExpiry :: ()
readLocalTxSubmissionPending :: ()
putLocalTxSubmission :: ()
getTx :: ()
readTxHistory :: ()
putTxHistory :: ()
readDelegationRewardBalance :: ()
putDelegationRewardBalance :: ()
putDelegationCertificate :: ()
isStakeKeyRegistered :: ()
readWalletMeta :: ()
putWalletMeta :: ()
listCheckpoints :: ()
readCheckpoint :: ()
putCheckpoint :: ()
walletsDB :: ()
listWallets :: ()
removeWallet :: ()
initializeWallet :: ()
..} -> do
    Wallet s
cp <- (ErrNoSuchWallet -> ErrReadPolicyPublicKey)
-> ExceptT ErrNoSuchWallet IO (Wallet s)
-> ExceptT ErrReadPolicyPublicKey IO (Wallet s)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ErrNoSuchWallet -> ErrReadPolicyPublicKey
ErrReadPolicyPublicKeyNoSuchWallet
        (ExceptT ErrNoSuchWallet IO (Wallet s)
 -> ExceptT ErrReadPolicyPublicKey IO (Wallet s))
-> ExceptT ErrNoSuchWallet IO (Wallet s)
-> ExceptT ErrReadPolicyPublicKey IO (Wallet s)
forall a b. (a -> b) -> a -> b
$ (stm (Either ErrNoSuchWallet (Wallet s))
 -> IO (Either ErrNoSuchWallet (Wallet s)))
-> ExceptT ErrNoSuchWallet stm (Wallet s)
-> ExceptT ErrNoSuchWallet IO (Wallet s)
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT stm (Either ErrNoSuchWallet (Wallet s))
-> IO (Either ErrNoSuchWallet (Wallet s))
forall a. stm a -> IO a
atomically
        (ExceptT ErrNoSuchWallet stm (Wallet s)
 -> ExceptT ErrNoSuchWallet IO (Wallet s))
-> ExceptT ErrNoSuchWallet stm (Wallet s)
-> ExceptT ErrNoSuchWallet IO (Wallet s)
forall a b. (a -> b) -> a -> b
$ WalletId
-> stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s)
forall (m :: * -> *) a.
Monad m =>
WalletId -> m (Maybe a) -> ExceptT ErrNoSuchWallet m a
withNoSuchWallet WalletId
wid
        (stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s))
-> stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s)
forall a b. (a -> b) -> a -> b
$ WalletId -> stm (Maybe (Wallet s))
readCheckpoint WalletId
wid
    case TypeRep s -> TypeRep shelley -> Maybe (s :~: shelley)
forall k (f :: k -> *) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality (Typeable s => TypeRep s
forall k (a :: k). Typeable a => TypeRep a
typeRep @s) (Typeable shelley => TypeRep shelley
forall k (a :: k). Typeable a => TypeRep a
typeRep @shelley) of
        Maybe (s :~: shelley)
Nothing ->
            ErrReadPolicyPublicKey
-> ExceptT
     ErrReadPolicyPublicKey IO (XPub, NonEmpty DerivationIndex)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ErrReadPolicyPublicKey
ErrReadPolicyPublicKeyNotAShelleyWallet
        Just s :~: shelley
Refl -> do
            let s :: s
s = Wallet s -> s
forall s. Wallet s -> s
getState Wallet s
cp
            case SeqState n ShelleyKey -> Maybe (ShelleyKey 'PolicyK XPub)
forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
SeqState n k -> Maybe (k 'PolicyK XPub)
Seq.policyXPub s
SeqState n ShelleyKey
s of
                Maybe (ShelleyKey 'PolicyK XPub)
Nothing ->
                    ErrReadPolicyPublicKey
-> ExceptT
     ErrReadPolicyPublicKey IO (XPub, NonEmpty DerivationIndex)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ErrReadPolicyPublicKey
ErrReadPolicyPublicKeyAbsent
                Just ShelleyKey 'PolicyK XPub
xpub ->
                    (XPub, NonEmpty DerivationIndex)
-> ExceptT
     ErrReadPolicyPublicKey IO (XPub, NonEmpty DerivationIndex)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShelleyKey 'PolicyK XPub -> XPub
forall (key :: Depth -> * -> *) (depth :: Depth) raw.
WalletKey key =>
key depth raw -> raw
getRawKey ShelleyKey 'PolicyK XPub
xpub, NonEmpty DerivationIndex
policyDerivationPath)
  where
    db :: DBLayer IO s k
db = ctx
ctx ctx
-> ((DBLayer IO s k -> Const (DBLayer IO s k) (DBLayer IO s k))
    -> ctx -> Const (DBLayer IO s k) ctx)
-> DBLayer IO s k
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx. HasDBLayer IO s k ctx => Lens' ctx (DBLayer IO s k)
forall (m :: * -> *) s (k :: Depth -> * -> *) ctx.
HasDBLayer m s k ctx =>
Lens' ctx (DBLayer m s k)
dbLayer @IO @s @k

-- | Query the node for the reward balance of a given wallet.
--
-- Rather than force all callers of 'readWallet' to wait for fetching the
-- account balance (via the 'NetworkLayer'), we expose this function for it.
queryRewardBalance
    :: forall ctx.
        ( HasNetworkLayer IO ctx
        )
    => ctx
    -> RewardAccount
    -> ExceptT ErrFetchRewards IO Coin
queryRewardBalance :: ctx -> RewardAccount -> ExceptT ErrFetchRewards IO Coin
queryRewardBalance ctx
ctx RewardAccount
acct = do
    IO Coin -> ExceptT ErrFetchRewards IO Coin
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Coin -> ExceptT ErrFetchRewards IO Coin)
-> IO Coin -> ExceptT ErrFetchRewards IO Coin
forall a b. (a -> b) -> a -> b
$ NetworkLayer IO Block -> RewardAccount -> IO Coin
forall (m :: * -> *) block.
NetworkLayer m block -> RewardAccount -> m Coin
getCachedRewardAccountBalance NetworkLayer IO Block
nw RewardAccount
acct
  where
    nw :: NetworkLayer IO Block
nw = ctx
ctx ctx
-> ((NetworkLayer IO Block
     -> Const (NetworkLayer IO Block) (NetworkLayer IO Block))
    -> ctx -> Const (NetworkLayer IO Block) ctx)
-> NetworkLayer IO Block
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. (NetworkLayer IO Block
 -> Const (NetworkLayer IO Block) (NetworkLayer IO Block))
-> ctx -> Const (NetworkLayer IO Block) ctx
forall (m :: * -> *) ctx.
HasNetworkLayer m ctx =>
Lens' ctx (NetworkLayer m Block)
networkLayer

manageRewardBalance
    :: forall ctx s k (n :: NetworkDiscriminant).
        ( HasLogger IO WalletWorkerLog ctx
        , HasNetworkLayer IO ctx
        , HasDBLayer IO s k ctx
        , Typeable s
        , Typeable n
        )
    => Proxy n
    -> ctx
    -> WalletId
    -> IO ()
manageRewardBalance :: Proxy n -> ctx -> WalletId -> IO ()
manageRewardBalance Proxy n
_ ctx
ctx WalletId
wid = DBLayer IO s k
db DBLayer IO s k -> (DBLayer IO s k -> IO ()) -> IO ()
forall a b. a -> (a -> b) -> b
& \DBLayer{stm [WalletId]
DBVar stm (DeltaMap WalletId (DeltaWalletState s))
WalletId -> stm [LocalTxSubmissionStatus SealedTx]
WalletId -> stm [ChainPoint]
WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
WalletId -> stm (Maybe GenesisParameters)
WalletId -> stm (Maybe WalletMetadata)
WalletId -> stm (Maybe (Wallet s))
WalletId -> stm Coin
WalletId -> ExceptT ErrNoSuchWallet stm Bool
WalletId -> ExceptT ErrNoSuchWallet stm ()
WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
forall a. stm a -> IO a
atomically :: forall a. stm a -> IO a
prune :: WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
rollbackTo :: WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
readGenesisParameters :: WalletId -> stm (Maybe GenesisParameters)
readPrivateKey :: WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
putPrivateKey :: WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
removePendingOrExpiredTx :: WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
updatePendingTxForExpiry :: WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
readLocalTxSubmissionPending :: WalletId -> stm [LocalTxSubmissionStatus SealedTx]
putLocalTxSubmission :: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
getTx :: WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
readTxHistory :: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
putTxHistory :: WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
readDelegationRewardBalance :: WalletId -> stm Coin
putDelegationRewardBalance :: WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
putDelegationCertificate :: WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
isStakeKeyRegistered :: WalletId -> ExceptT ErrNoSuchWallet stm Bool
readWalletMeta :: WalletId -> stm (Maybe WalletMetadata)
putWalletMeta :: WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
listCheckpoints :: WalletId -> stm [ChainPoint]
readCheckpoint :: WalletId -> stm (Maybe (Wallet s))
putCheckpoint :: WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
walletsDB :: DBVar stm (DeltaMap WalletId (DeltaWalletState s))
listWallets :: stm [WalletId]
removeWallet :: WalletId -> ExceptT ErrNoSuchWallet stm ()
initializeWallet :: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
atomically :: ()
prune :: ()
rollbackTo :: ()
readGenesisParameters :: ()
readPrivateKey :: ()
putPrivateKey :: ()
removePendingOrExpiredTx :: ()
updatePendingTxForExpiry :: ()
readLocalTxSubmissionPending :: ()
putLocalTxSubmission :: ()
getTx :: ()
readTxHistory :: ()
putTxHistory :: ()
readDelegationRewardBalance :: ()
putDelegationRewardBalance :: ()
putDelegationCertificate :: ()
isStakeKeyRegistered :: ()
readWalletMeta :: ()
putWalletMeta :: ()
listCheckpoints :: ()
readCheckpoint :: ()
putCheckpoint :: ()
walletsDB :: ()
listWallets :: ()
removeWallet :: ()
initializeWallet :: ()
..} -> do
    (BlockHeader -> IO ()) -> IO ()
watchNodeTip ((BlockHeader -> IO ()) -> IO ())
-> (BlockHeader -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \BlockHeader
bh -> do
         Tracer IO WalletLog -> WalletLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO WalletLog
tr (WalletLog -> IO ()) -> WalletLog -> IO ()
forall a b. (a -> b) -> a -> b
$ BlockHeader -> WalletLog
MsgRewardBalanceQuery BlockHeader
bh
         Either ErrFetchRewards Coin
query <- ExceptT ErrFetchRewards IO Coin -> IO (Either ErrFetchRewards Coin)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ErrFetchRewards IO Coin
 -> IO (Either ErrFetchRewards Coin))
-> ExceptT ErrFetchRewards IO Coin
-> IO (Either ErrFetchRewards Coin)
forall a b. (a -> b) -> a -> b
$ do
            (RewardAccount
acct, XPub
_, NonEmpty DerivationIndex
_) <- (ErrReadRewardAccount -> ErrFetchRewards)
-> ExceptT
     ErrReadRewardAccount
     IO
     (RewardAccount, XPub, NonEmpty DerivationIndex)
-> ExceptT
     ErrFetchRewards IO (RewardAccount, XPub, NonEmpty DerivationIndex)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ErrReadRewardAccount -> ErrFetchRewards
ErrFetchRewardsReadRewardAccount (ExceptT
   ErrReadRewardAccount
   IO
   (RewardAccount, XPub, NonEmpty DerivationIndex)
 -> ExceptT
      ErrFetchRewards IO (RewardAccount, XPub, NonEmpty DerivationIndex))
-> ExceptT
     ErrReadRewardAccount
     IO
     (RewardAccount, XPub, NonEmpty DerivationIndex)
-> ExceptT
     ErrFetchRewards IO (RewardAccount, XPub, NonEmpty DerivationIndex)
forall a b. (a -> b) -> a -> b
$
                ctx
-> WalletId
-> ExceptT
     ErrReadRewardAccount
     IO
     (RewardAccount, XPub, NonEmpty DerivationIndex)
forall ctx s (k :: Depth -> * -> *) (n :: NetworkDiscriminant)
       shelley.
(HasDBLayer IO s k ctx, shelley ~ SeqState n ShelleyKey,
 Typeable n, Typeable s) =>
ctx
-> WalletId
-> ExceptT
     ErrReadRewardAccount
     IO
     (RewardAccount, XPub, NonEmpty DerivationIndex)
readRewardAccount @ctx @s @k @n ctx
ctx WalletId
wid
            ctx -> RewardAccount -> ExceptT ErrFetchRewards IO Coin
forall ctx.
HasNetworkLayer IO ctx =>
ctx -> RewardAccount -> ExceptT ErrFetchRewards IO Coin
queryRewardBalance @ctx ctx
ctx RewardAccount
acct
         Tracer IO WalletLog -> WalletLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO WalletLog
tr (WalletLog -> IO ()) -> WalletLog -> IO ()
forall a b. (a -> b) -> a -> b
$ Either ErrFetchRewards Coin -> WalletLog
MsgRewardBalanceResult Either ErrFetchRewards Coin
query
         case Either ErrFetchRewards Coin
query of
            Right Coin
amt -> do
                Either ErrNoSuchWallet ()
res <- stm (Either ErrNoSuchWallet ()) -> IO (Either ErrNoSuchWallet ())
forall a. stm a -> IO a
atomically (stm (Either ErrNoSuchWallet ()) -> IO (Either ErrNoSuchWallet ()))
-> stm (Either ErrNoSuchWallet ())
-> IO (Either ErrNoSuchWallet ())
forall a b. (a -> b) -> a -> b
$ ExceptT ErrNoSuchWallet stm () -> stm (Either ErrNoSuchWallet ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ErrNoSuchWallet stm () -> stm (Either ErrNoSuchWallet ()))
-> ExceptT ErrNoSuchWallet stm ()
-> stm (Either ErrNoSuchWallet ())
forall a b. (a -> b) -> a -> b
$
                    WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
putDelegationRewardBalance WalletId
wid Coin
amt
                -- It can happen that the wallet doesn't exist _yet_, whereas we
                -- already have a reward balance. If that's the case, we log and
                -- move on.
                case Either ErrNoSuchWallet ()
res of
                    Left ErrNoSuchWallet
err -> Tracer IO WalletLog -> WalletLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO WalletLog
tr (WalletLog -> IO ()) -> WalletLog -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrNoSuchWallet -> WalletLog
MsgRewardBalanceNoSuchWallet ErrNoSuchWallet
err
                    Right () -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Left ErrFetchRewards
_err ->
                -- Occasionally failing to query is generally not fatal. It will
                -- just update the balance next time the tip changes.
                () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Tracer IO WalletLog -> WalletLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO WalletLog
tr WalletLog
MsgRewardBalanceExited

  where
    db :: DBLayer IO s k
db = ctx
ctx ctx
-> ((DBLayer IO s k -> Const (DBLayer IO s k) (DBLayer IO s k))
    -> ctx -> Const (DBLayer IO s k) ctx)
-> DBLayer IO s k
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx. HasDBLayer IO s k ctx => Lens' ctx (DBLayer IO s k)
forall (m :: * -> *) s (k :: Depth -> * -> *) ctx.
HasDBLayer m s k ctx =>
Lens' ctx (DBLayer m s k)
dbLayer @IO @s @k
    NetworkLayer{(BlockHeader -> IO ()) -> IO ()
watchNodeTip :: forall (m :: * -> *) block.
NetworkLayer m block -> (BlockHeader -> m ()) -> m ()
watchNodeTip :: (BlockHeader -> IO ()) -> IO ()
watchNodeTip} = ctx
ctx ctx
-> ((NetworkLayer IO Block
     -> Const (NetworkLayer IO Block) (NetworkLayer IO Block))
    -> ctx -> Const (NetworkLayer IO Block) ctx)
-> NetworkLayer IO Block
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. (NetworkLayer IO Block
 -> Const (NetworkLayer IO Block) (NetworkLayer IO Block))
-> ctx -> Const (NetworkLayer IO Block) ctx
forall (m :: * -> *) ctx.
HasNetworkLayer m ctx =>
Lens' ctx (NetworkLayer m Block)
networkLayer
    tr :: Tracer IO WalletLog
tr = (WalletLog -> WalletWorkerLog)
-> Tracer IO WalletWorkerLog -> Tracer IO WalletLog
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap WalletLog -> WalletWorkerLog
MsgWallet (Tracer IO WalletWorkerLog -> Tracer IO WalletLog)
-> Tracer IO WalletWorkerLog -> Tracer IO WalletLog
forall a b. (a -> b) -> a -> b
$ ctx
ctx ctx
-> ((Tracer IO WalletWorkerLog
     -> Const (Tracer IO WalletWorkerLog) (Tracer IO WalletWorkerLog))
    -> ctx -> Const (Tracer IO WalletWorkerLog) ctx)
-> Tracer IO WalletWorkerLog
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx.
HasLogger IO WalletWorkerLog ctx =>
Lens' ctx (Tracer IO WalletWorkerLog)
forall (m :: * -> *) msg ctx.
HasLogger m msg ctx =>
Lens' ctx (Tracer m msg)
logger @_ @WalletWorkerLog

{-------------------------------------------------------------------------------
                                    Address
-------------------------------------------------------------------------------}

lookupTxIns
    :: forall ctx s k .
        ( HasDBLayer IO s k ctx
        , IsOurs s Address
        )
    => ctx
    -> WalletId
    -> [TxIn]
    -> ExceptT ErrDecodeTx IO [(TxIn, Maybe (TxOut, NonEmpty DerivationIndex))]
lookupTxIns :: ctx
-> WalletId
-> [TxIn]
-> ExceptT
     ErrDecodeTx IO [(TxIn, Maybe (TxOut, NonEmpty DerivationIndex))]
lookupTxIns ctx
ctx WalletId
wid [TxIn]
txins = DBLayer IO s k
db DBLayer IO s k
-> (DBLayer IO s k
    -> ExceptT
         ErrDecodeTx IO [(TxIn, Maybe (TxOut, NonEmpty DerivationIndex))])
-> ExceptT
     ErrDecodeTx IO [(TxIn, Maybe (TxOut, NonEmpty DerivationIndex))]
forall a b. a -> (a -> b) -> b
& \DBLayer{stm [WalletId]
DBVar stm (DeltaMap WalletId (DeltaWalletState s))
WalletId -> stm [LocalTxSubmissionStatus SealedTx]
WalletId -> stm [ChainPoint]
WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
WalletId -> stm (Maybe GenesisParameters)
WalletId -> stm (Maybe WalletMetadata)
WalletId -> stm (Maybe (Wallet s))
WalletId -> stm Coin
WalletId -> ExceptT ErrNoSuchWallet stm Bool
WalletId -> ExceptT ErrNoSuchWallet stm ()
WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
forall a. stm a -> IO a
atomically :: forall a. stm a -> IO a
prune :: WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
rollbackTo :: WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
readGenesisParameters :: WalletId -> stm (Maybe GenesisParameters)
readPrivateKey :: WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
putPrivateKey :: WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
removePendingOrExpiredTx :: WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
updatePendingTxForExpiry :: WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
readLocalTxSubmissionPending :: WalletId -> stm [LocalTxSubmissionStatus SealedTx]
putLocalTxSubmission :: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
getTx :: WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
readTxHistory :: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
putTxHistory :: WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
readDelegationRewardBalance :: WalletId -> stm Coin
putDelegationRewardBalance :: WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
putDelegationCertificate :: WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
isStakeKeyRegistered :: WalletId -> ExceptT ErrNoSuchWallet stm Bool
readWalletMeta :: WalletId -> stm (Maybe WalletMetadata)
putWalletMeta :: WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
listCheckpoints :: WalletId -> stm [ChainPoint]
readCheckpoint :: WalletId -> stm (Maybe (Wallet s))
putCheckpoint :: WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
walletsDB :: DBVar stm (DeltaMap WalletId (DeltaWalletState s))
listWallets :: stm [WalletId]
removeWallet :: WalletId -> ExceptT ErrNoSuchWallet stm ()
initializeWallet :: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
atomically :: ()
prune :: ()
rollbackTo :: ()
readGenesisParameters :: ()
readPrivateKey :: ()
putPrivateKey :: ()
removePendingOrExpiredTx :: ()
updatePendingTxForExpiry :: ()
readLocalTxSubmissionPending :: ()
putLocalTxSubmission :: ()
getTx :: ()
readTxHistory :: ()
putTxHistory :: ()
readDelegationRewardBalance :: ()
putDelegationRewardBalance :: ()
putDelegationCertificate :: ()
isStakeKeyRegistered :: ()
readWalletMeta :: ()
putWalletMeta :: ()
listCheckpoints :: ()
readCheckpoint :: ()
putCheckpoint :: ()
walletsDB :: ()
listWallets :: ()
removeWallet :: ()
initializeWallet :: ()
..} -> do
    Wallet s
cp <- (stm (Either ErrDecodeTx (Wallet s))
 -> IO (Either ErrDecodeTx (Wallet s)))
-> ExceptT ErrDecodeTx stm (Wallet s)
-> ExceptT ErrDecodeTx IO (Wallet s)
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT stm (Either ErrDecodeTx (Wallet s))
-> IO (Either ErrDecodeTx (Wallet s))
forall a. stm a -> IO a
atomically
          (ExceptT ErrDecodeTx stm (Wallet s)
 -> ExceptT ErrDecodeTx IO (Wallet s))
-> ExceptT ErrDecodeTx stm (Wallet s)
-> ExceptT ErrDecodeTx IO (Wallet s)
forall a b. (a -> b) -> a -> b
$ (ErrNoSuchWallet -> ErrDecodeTx)
-> ExceptT ErrNoSuchWallet stm (Wallet s)
-> ExceptT ErrDecodeTx stm (Wallet s)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ErrNoSuchWallet -> ErrDecodeTx
ErrDecodeTxNoSuchWallet
          (ExceptT ErrNoSuchWallet stm (Wallet s)
 -> ExceptT ErrDecodeTx stm (Wallet s))
-> ExceptT ErrNoSuchWallet stm (Wallet s)
-> ExceptT ErrDecodeTx stm (Wallet s)
forall a b. (a -> b) -> a -> b
$ WalletId
-> stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s)
forall (m :: * -> *) a.
Monad m =>
WalletId -> m (Maybe a) -> ExceptT ErrNoSuchWallet m a
withNoSuchWallet WalletId
wid
          (stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s))
-> stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s)
forall a b. (a -> b) -> a -> b
$ WalletId -> stm (Maybe (Wallet s))
readCheckpoint WalletId
wid
    [(TxIn, Maybe (TxOut, NonEmpty DerivationIndex))]
-> ExceptT
     ErrDecodeTx IO [(TxIn, Maybe (TxOut, NonEmpty DerivationIndex))]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(TxIn, Maybe (TxOut, NonEmpty DerivationIndex))]
 -> ExceptT
      ErrDecodeTx IO [(TxIn, Maybe (TxOut, NonEmpty DerivationIndex))])
-> [(TxIn, Maybe (TxOut, NonEmpty DerivationIndex))]
-> ExceptT
     ErrDecodeTx IO [(TxIn, Maybe (TxOut, NonEmpty DerivationIndex))]
forall a b. (a -> b) -> a -> b
$ (TxIn -> (TxIn, Maybe (TxOut, NonEmpty DerivationIndex)))
-> [TxIn] -> [(TxIn, Maybe (TxOut, NonEmpty DerivationIndex))]
forall a b. (a -> b) -> [a] -> [b]
map (\TxIn
i -> (TxIn
i, Wallet s -> TxIn -> Maybe (TxOut, NonEmpty DerivationIndex)
lookupTxIn Wallet s
cp TxIn
i)) [TxIn]
txins
  where
    db :: DBLayer IO s k
db = ctx
ctx ctx
-> ((DBLayer IO s k -> Const (DBLayer IO s k) (DBLayer IO s k))
    -> ctx -> Const (DBLayer IO s k) ctx)
-> DBLayer IO s k
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx. HasDBLayer IO s k ctx => Lens' ctx (DBLayer IO s k)
forall (m :: * -> *) s (k :: Depth -> * -> *) ctx.
HasDBLayer m s k ctx =>
Lens' ctx (DBLayer m s k)
dbLayer @IO @s @k
    lookupTxIn :: Wallet s -> TxIn -> Maybe (TxOut, NonEmpty DerivationIndex)
    lookupTxIn :: Wallet s -> TxIn -> Maybe (TxOut, NonEmpty DerivationIndex)
lookupTxIn Wallet s
cp TxIn
txIn = do
        out :: TxOut
out@(TxOut Address
addr TokenBundle
_) <- TxIn -> UTxO -> Maybe TxOut
UTxO.lookup TxIn
txIn (Set Tx -> Wallet s -> UTxO
forall s. IsOurs s Address => Set Tx -> Wallet s -> UTxO
totalUTxO Set Tx
forall a. Monoid a => a
mempty Wallet s
cp)
        NonEmpty DerivationIndex
path <- (Maybe (NonEmpty DerivationIndex), s)
-> Maybe (NonEmpty DerivationIndex)
forall a b. (a, b) -> a
fst ((Maybe (NonEmpty DerivationIndex), s)
 -> Maybe (NonEmpty DerivationIndex))
-> (Maybe (NonEmpty DerivationIndex), s)
-> Maybe (NonEmpty DerivationIndex)
forall a b. (a -> b) -> a -> b
$ Address -> s -> (Maybe (NonEmpty DerivationIndex), s)
forall s entity.
IsOurs s entity =>
entity -> s -> (Maybe (NonEmpty DerivationIndex), s)
isOurs Address
addr (Wallet s -> s
forall s. Wallet s -> s
getState Wallet s
cp)
        (TxOut, NonEmpty DerivationIndex)
-> Maybe (TxOut, NonEmpty DerivationIndex)
forall (m :: * -> *) a. Monad m => a -> m a
return (TxOut
out, NonEmpty DerivationIndex
path)

lookupTxOuts
    :: forall ctx s k .
        ( HasDBLayer IO s k ctx
        , IsOurs s Address
        )
    => ctx
    -> WalletId
    -> [TxOut]
    -> ExceptT ErrDecodeTx IO [(TxOut, Maybe (NonEmpty DerivationIndex))]
lookupTxOuts :: ctx
-> WalletId
-> [TxOut]
-> ExceptT
     ErrDecodeTx IO [(TxOut, Maybe (NonEmpty DerivationIndex))]
lookupTxOuts ctx
ctx WalletId
wid [TxOut]
txouts = DBLayer IO s k
db DBLayer IO s k
-> (DBLayer IO s k
    -> ExceptT
         ErrDecodeTx IO [(TxOut, Maybe (NonEmpty DerivationIndex))])
-> ExceptT
     ErrDecodeTx IO [(TxOut, Maybe (NonEmpty DerivationIndex))]
forall a b. a -> (a -> b) -> b
& \DBLayer{stm [WalletId]
DBVar stm (DeltaMap WalletId (DeltaWalletState s))
WalletId -> stm [LocalTxSubmissionStatus SealedTx]
WalletId -> stm [ChainPoint]
WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
WalletId -> stm (Maybe GenesisParameters)
WalletId -> stm (Maybe WalletMetadata)
WalletId -> stm (Maybe (Wallet s))
WalletId -> stm Coin
WalletId -> ExceptT ErrNoSuchWallet stm Bool
WalletId -> ExceptT ErrNoSuchWallet stm ()
WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
forall a. stm a -> IO a
atomically :: forall a. stm a -> IO a
prune :: WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
rollbackTo :: WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
readGenesisParameters :: WalletId -> stm (Maybe GenesisParameters)
readPrivateKey :: WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
putPrivateKey :: WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
removePendingOrExpiredTx :: WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
updatePendingTxForExpiry :: WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
readLocalTxSubmissionPending :: WalletId -> stm [LocalTxSubmissionStatus SealedTx]
putLocalTxSubmission :: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
getTx :: WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
readTxHistory :: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
putTxHistory :: WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
readDelegationRewardBalance :: WalletId -> stm Coin
putDelegationRewardBalance :: WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
putDelegationCertificate :: WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
isStakeKeyRegistered :: WalletId -> ExceptT ErrNoSuchWallet stm Bool
readWalletMeta :: WalletId -> stm (Maybe WalletMetadata)
putWalletMeta :: WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
listCheckpoints :: WalletId -> stm [ChainPoint]
readCheckpoint :: WalletId -> stm (Maybe (Wallet s))
putCheckpoint :: WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
walletsDB :: DBVar stm (DeltaMap WalletId (DeltaWalletState s))
listWallets :: stm [WalletId]
removeWallet :: WalletId -> ExceptT ErrNoSuchWallet stm ()
initializeWallet :: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
atomically :: ()
prune :: ()
rollbackTo :: ()
readGenesisParameters :: ()
readPrivateKey :: ()
putPrivateKey :: ()
removePendingOrExpiredTx :: ()
updatePendingTxForExpiry :: ()
readLocalTxSubmissionPending :: ()
putLocalTxSubmission :: ()
getTx :: ()
readTxHistory :: ()
putTxHistory :: ()
readDelegationRewardBalance :: ()
putDelegationRewardBalance :: ()
putDelegationCertificate :: ()
isStakeKeyRegistered :: ()
readWalletMeta :: ()
putWalletMeta :: ()
listCheckpoints :: ()
readCheckpoint :: ()
putCheckpoint :: ()
walletsDB :: ()
listWallets :: ()
removeWallet :: ()
initializeWallet :: ()
..} -> do
    Wallet s
cp <- (stm (Either ErrDecodeTx (Wallet s))
 -> IO (Either ErrDecodeTx (Wallet s)))
-> ExceptT ErrDecodeTx stm (Wallet s)
-> ExceptT ErrDecodeTx IO (Wallet s)
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT stm (Either ErrDecodeTx (Wallet s))
-> IO (Either ErrDecodeTx (Wallet s))
forall a. stm a -> IO a
atomically
          (ExceptT ErrDecodeTx stm (Wallet s)
 -> ExceptT ErrDecodeTx IO (Wallet s))
-> ExceptT ErrDecodeTx stm (Wallet s)
-> ExceptT ErrDecodeTx IO (Wallet s)
forall a b. (a -> b) -> a -> b
$ (ErrNoSuchWallet -> ErrDecodeTx)
-> ExceptT ErrNoSuchWallet stm (Wallet s)
-> ExceptT ErrDecodeTx stm (Wallet s)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ErrNoSuchWallet -> ErrDecodeTx
ErrDecodeTxNoSuchWallet
          (ExceptT ErrNoSuchWallet stm (Wallet s)
 -> ExceptT ErrDecodeTx stm (Wallet s))
-> ExceptT ErrNoSuchWallet stm (Wallet s)
-> ExceptT ErrDecodeTx stm (Wallet s)
forall a b. (a -> b) -> a -> b
$ WalletId
-> stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s)
forall (m :: * -> *) a.
Monad m =>
WalletId -> m (Maybe a) -> ExceptT ErrNoSuchWallet m a
withNoSuchWallet WalletId
wid
          (stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s))
-> stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s)
forall a b. (a -> b) -> a -> b
$ WalletId -> stm (Maybe (Wallet s))
readCheckpoint WalletId
wid
    -- NOTE: We evolve the state (in practice an address pool) as we loop
    -- through the outputs, but we don't consider pending transactions.
    -- /Theoretically/ the outputs might only be discoverable after discovering
    -- outputs other pending transactions.
    [(TxOut, Maybe (NonEmpty DerivationIndex))]
-> ExceptT
     ErrDecodeTx IO [(TxOut, Maybe (NonEmpty DerivationIndex))]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(TxOut, Maybe (NonEmpty DerivationIndex))]
 -> ExceptT
      ErrDecodeTx IO [(TxOut, Maybe (NonEmpty DerivationIndex))])
-> [(TxOut, Maybe (NonEmpty DerivationIndex))]
-> ExceptT
     ErrDecodeTx IO [(TxOut, Maybe (NonEmpty DerivationIndex))]
forall a b. (a -> b) -> a -> b
$ (State s [(TxOut, Maybe (NonEmpty DerivationIndex))]
 -> s -> [(TxOut, Maybe (NonEmpty DerivationIndex))])
-> s
-> State s [(TxOut, Maybe (NonEmpty DerivationIndex))]
-> [(TxOut, Maybe (NonEmpty DerivationIndex))]
forall a b c. (a -> b -> c) -> b -> a -> c
flip State s [(TxOut, Maybe (NonEmpty DerivationIndex))]
-> s -> [(TxOut, Maybe (NonEmpty DerivationIndex))]
forall s a. State s a -> s -> a
evalState (Wallet s -> s
forall s. Wallet s -> s
getState Wallet s
cp) (State s [(TxOut, Maybe (NonEmpty DerivationIndex))]
 -> [(TxOut, Maybe (NonEmpty DerivationIndex))])
-> State s [(TxOut, Maybe (NonEmpty DerivationIndex))]
-> [(TxOut, Maybe (NonEmpty DerivationIndex))]
forall a b. (a -> b) -> a -> b
$ [TxOut]
-> (TxOut
    -> StateT s Identity (TxOut, Maybe (NonEmpty DerivationIndex)))
-> State s [(TxOut, Maybe (NonEmpty DerivationIndex))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [TxOut]
txouts ((TxOut
  -> StateT s Identity (TxOut, Maybe (NonEmpty DerivationIndex)))
 -> State s [(TxOut, Maybe (NonEmpty DerivationIndex))])
-> (TxOut
    -> StateT s Identity (TxOut, Maybe (NonEmpty DerivationIndex)))
-> State s [(TxOut, Maybe (NonEmpty DerivationIndex))]
forall a b. (a -> b) -> a -> b
$ \out :: TxOut
out@(TxOut Address
addr TokenBundle
_) -> do
        (TxOut
out,) (Maybe (NonEmpty DerivationIndex)
 -> (TxOut, Maybe (NonEmpty DerivationIndex)))
-> StateT s Identity (Maybe (NonEmpty DerivationIndex))
-> StateT s Identity (TxOut, Maybe (NonEmpty DerivationIndex))
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 (Address -> s -> (Maybe (NonEmpty DerivationIndex), s)
forall s entity.
IsOurs s entity =>
entity -> s -> (Maybe (NonEmpty DerivationIndex), s)
isOurs Address
addr)
  where
    db :: DBLayer IO s k
db = ctx
ctx ctx
-> ((DBLayer IO s k -> Const (DBLayer IO s k) (DBLayer IO s k))
    -> ctx -> Const (DBLayer IO s k) ctx)
-> DBLayer IO s k
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx. HasDBLayer IO s k ctx => Lens' ctx (DBLayer IO s k)
forall (m :: * -> *) s (k :: Depth -> * -> *) ctx.
HasDBLayer m s k ctx =>
Lens' ctx (DBLayer m s k)
dbLayer @IO @s @k

-- | List all addresses of a wallet with their metadata. Addresses
-- are ordered from the most-recently-discovered to the oldest known.
listAddresses
    :: forall ctx s k.
        ( HasDBLayer IO s k ctx
        , CompareDiscovery s
        , KnownAddresses s
        )
    => ctx
    -> WalletId
    -> (s -> Address -> Maybe Address)
        -- ^ A function to normalize address, so that delegated addresses
        -- non-delegation addresses found in the transaction history are
        -- shown with their delegation settings.
        -- Use 'Just' for wallet without delegation settings.
    -> ExceptT ErrNoSuchWallet IO [(Address, AddressState, NonEmpty DerivationIndex)]
listAddresses :: ctx
-> WalletId
-> (s -> Address -> Maybe Address)
-> ExceptT
     ErrNoSuchWallet
     IO
     [(Address, AddressState, NonEmpty DerivationIndex)]
listAddresses ctx
ctx WalletId
wid s -> Address -> Maybe Address
normalize = DBLayer IO s k
db DBLayer IO s k
-> (DBLayer IO s k
    -> ExceptT
         ErrNoSuchWallet
         IO
         [(Address, AddressState, NonEmpty DerivationIndex)])
-> ExceptT
     ErrNoSuchWallet
     IO
     [(Address, AddressState, NonEmpty DerivationIndex)]
forall a b. a -> (a -> b) -> b
& \DBLayer{stm [WalletId]
DBVar stm (DeltaMap WalletId (DeltaWalletState s))
WalletId -> stm [LocalTxSubmissionStatus SealedTx]
WalletId -> stm [ChainPoint]
WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
WalletId -> stm (Maybe GenesisParameters)
WalletId -> stm (Maybe WalletMetadata)
WalletId -> stm (Maybe (Wallet s))
WalletId -> stm Coin
WalletId -> ExceptT ErrNoSuchWallet stm Bool
WalletId -> ExceptT ErrNoSuchWallet stm ()
WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
forall a. stm a -> IO a
atomically :: forall a. stm a -> IO a
prune :: WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
rollbackTo :: WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
readGenesisParameters :: WalletId -> stm (Maybe GenesisParameters)
readPrivateKey :: WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
putPrivateKey :: WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
removePendingOrExpiredTx :: WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
updatePendingTxForExpiry :: WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
readLocalTxSubmissionPending :: WalletId -> stm [LocalTxSubmissionStatus SealedTx]
putLocalTxSubmission :: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
getTx :: WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
readTxHistory :: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
putTxHistory :: WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
readDelegationRewardBalance :: WalletId -> stm Coin
putDelegationRewardBalance :: WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
putDelegationCertificate :: WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
isStakeKeyRegistered :: WalletId -> ExceptT ErrNoSuchWallet stm Bool
readWalletMeta :: WalletId -> stm (Maybe WalletMetadata)
putWalletMeta :: WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
listCheckpoints :: WalletId -> stm [ChainPoint]
readCheckpoint :: WalletId -> stm (Maybe (Wallet s))
putCheckpoint :: WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
walletsDB :: DBVar stm (DeltaMap WalletId (DeltaWalletState s))
listWallets :: stm [WalletId]
removeWallet :: WalletId -> ExceptT ErrNoSuchWallet stm ()
initializeWallet :: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
atomically :: ()
prune :: ()
rollbackTo :: ()
readGenesisParameters :: ()
readPrivateKey :: ()
putPrivateKey :: ()
removePendingOrExpiredTx :: ()
updatePendingTxForExpiry :: ()
readLocalTxSubmissionPending :: ()
putLocalTxSubmission :: ()
getTx :: ()
readTxHistory :: ()
putTxHistory :: ()
readDelegationRewardBalance :: ()
putDelegationRewardBalance :: ()
putDelegationCertificate :: ()
isStakeKeyRegistered :: ()
readWalletMeta :: ()
putWalletMeta :: ()
listCheckpoints :: ()
readCheckpoint :: ()
putCheckpoint :: ()
walletsDB :: ()
listWallets :: ()
removeWallet :: ()
initializeWallet :: ()
..} -> do
    Wallet s
cp <- (stm (Either ErrNoSuchWallet (Wallet s))
 -> IO (Either ErrNoSuchWallet (Wallet s)))
-> ExceptT ErrNoSuchWallet stm (Wallet s)
-> ExceptT ErrNoSuchWallet IO (Wallet s)
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT stm (Either ErrNoSuchWallet (Wallet s))
-> IO (Either ErrNoSuchWallet (Wallet s))
forall a. stm a -> IO a
atomically
        (ExceptT ErrNoSuchWallet stm (Wallet s)
 -> ExceptT ErrNoSuchWallet IO (Wallet s))
-> ExceptT ErrNoSuchWallet stm (Wallet s)
-> ExceptT ErrNoSuchWallet IO (Wallet s)
forall a b. (a -> b) -> a -> b
$ WalletId
-> stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s)
forall (m :: * -> *) a.
Monad m =>
WalletId -> m (Maybe a) -> ExceptT ErrNoSuchWallet m a
withNoSuchWallet WalletId
wid
        (stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s))
-> stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s)
forall a b. (a -> b) -> a -> b
$ WalletId -> stm (Maybe (Wallet s))
readCheckpoint WalletId
wid
    let s :: s
s = Wallet s -> s
forall s. Wallet s -> s
getState Wallet s
cp

    -- FIXME
    -- Stream this instead of returning it as a single block.
    [(Address, AddressState, NonEmpty DerivationIndex)]
-> ExceptT
     ErrNoSuchWallet
     IO
     [(Address, AddressState, NonEmpty DerivationIndex)]
forall (m :: * -> *) a. Monad m => a -> m a
return
        ([(Address, AddressState, NonEmpty DerivationIndex)]
 -> ExceptT
      ErrNoSuchWallet
      IO
      [(Address, AddressState, NonEmpty DerivationIndex)])
-> [(Address, AddressState, NonEmpty DerivationIndex)]
-> ExceptT
     ErrNoSuchWallet
     IO
     [(Address, AddressState, NonEmpty DerivationIndex)]
forall a b. (a -> b) -> a -> b
$ ((Address, AddressState, NonEmpty DerivationIndex)
 -> (Address, AddressState, NonEmpty DerivationIndex) -> Ordering)
-> [(Address, AddressState, NonEmpty DerivationIndex)]
-> [(Address, AddressState, NonEmpty DerivationIndex)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
L.sortBy (\(Address
a,AddressState
_,NonEmpty DerivationIndex
_) (Address
b,AddressState
_,NonEmpty DerivationIndex
_) -> s -> Address -> Address -> Ordering
forall s. CompareDiscovery s => s -> Address -> Address -> Ordering
compareDiscovery s
s Address
a Address
b)
        ([(Address, AddressState, NonEmpty DerivationIndex)]
 -> [(Address, AddressState, NonEmpty DerivationIndex)])
-> [(Address, AddressState, NonEmpty DerivationIndex)]
-> [(Address, AddressState, NonEmpty DerivationIndex)]
forall a b. (a -> b) -> a -> b
$ ((Address, AddressState, NonEmpty DerivationIndex)
 -> Maybe (Address, AddressState, NonEmpty DerivationIndex))
-> [(Address, AddressState, NonEmpty DerivationIndex)]
-> [(Address, AddressState, NonEmpty DerivationIndex)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(Address
addr, AddressState
st,NonEmpty DerivationIndex
path) -> (,AddressState
st,NonEmpty DerivationIndex
path) (Address -> (Address, AddressState, NonEmpty DerivationIndex))
-> Maybe Address
-> Maybe (Address, AddressState, NonEmpty DerivationIndex)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> s -> Address -> Maybe Address
normalize s
s Address
addr)
        ([(Address, AddressState, NonEmpty DerivationIndex)]
 -> [(Address, AddressState, NonEmpty DerivationIndex)])
-> [(Address, AddressState, NonEmpty DerivationIndex)]
-> [(Address, AddressState, NonEmpty DerivationIndex)]
forall a b. (a -> b) -> a -> b
$ s -> [(Address, AddressState, NonEmpty DerivationIndex)]
forall s.
KnownAddresses s =>
s -> [(Address, AddressState, NonEmpty DerivationIndex)]
knownAddresses s
s
  where
    db :: DBLayer IO s k
db = ctx
ctx ctx
-> ((DBLayer IO s k -> Const (DBLayer IO s k) (DBLayer IO s k))
    -> ctx -> Const (DBLayer IO s k) ctx)
-> DBLayer IO s k
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx. HasDBLayer IO s k ctx => Lens' ctx (DBLayer IO s k)
forall (m :: * -> *) s (k :: Depth -> * -> *) ctx.
HasDBLayer m s k ctx =>
Lens' ctx (DBLayer m s k)
dbLayer @IO @s @k

createRandomAddress
    :: forall ctx s k n.
        ( HasDBLayer IO s k ctx
        , PaymentAddress n k
        , RndStateLike s
        , k ~ ByronKey
        , AddressBookIso s
        )
    => ctx
    -> WalletId
    -> Passphrase "user"
    -> Maybe (Index 'Hardened 'AddressK)
    -> ExceptT ErrCreateRandomAddress IO (Address, NonEmpty DerivationIndex)
createRandomAddress :: ctx
-> WalletId
-> Passphrase "user"
-> Maybe (Index 'Hardened 'AddressK)
-> ExceptT
     ErrCreateRandomAddress IO (Address, NonEmpty DerivationIndex)
createRandomAddress ctx
ctx WalletId
wid Passphrase "user"
pwd Maybe (Index 'Hardened 'AddressK)
mIx = DBLayer IO s k
db DBLayer IO s k
-> (DBLayer IO s k
    -> ExceptT
         ErrCreateRandomAddress IO (Address, NonEmpty DerivationIndex))
-> ExceptT
     ErrCreateRandomAddress IO (Address, NonEmpty DerivationIndex)
forall a b. a -> (a -> b) -> b
& \DBLayer{stm [WalletId]
DBVar stm (DeltaMap WalletId (DeltaWalletState s))
WalletId -> stm [LocalTxSubmissionStatus SealedTx]
WalletId -> stm [ChainPoint]
WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
WalletId -> stm (Maybe GenesisParameters)
WalletId -> stm (Maybe WalletMetadata)
WalletId -> stm (Maybe (Wallet s))
WalletId -> stm Coin
WalletId -> ExceptT ErrNoSuchWallet stm Bool
WalletId -> ExceptT ErrNoSuchWallet stm ()
WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
forall a. stm a -> IO a
atomically :: forall a. stm a -> IO a
prune :: WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
rollbackTo :: WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
readGenesisParameters :: WalletId -> stm (Maybe GenesisParameters)
readPrivateKey :: WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
putPrivateKey :: WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
removePendingOrExpiredTx :: WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
updatePendingTxForExpiry :: WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
readLocalTxSubmissionPending :: WalletId -> stm [LocalTxSubmissionStatus SealedTx]
putLocalTxSubmission :: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
getTx :: WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
readTxHistory :: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
putTxHistory :: WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
readDelegationRewardBalance :: WalletId -> stm Coin
putDelegationRewardBalance :: WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
putDelegationCertificate :: WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
isStakeKeyRegistered :: WalletId -> ExceptT ErrNoSuchWallet stm Bool
readWalletMeta :: WalletId -> stm (Maybe WalletMetadata)
putWalletMeta :: WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
listCheckpoints :: WalletId -> stm [ChainPoint]
readCheckpoint :: WalletId -> stm (Maybe (Wallet s))
putCheckpoint :: WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
walletsDB :: DBVar stm (DeltaMap WalletId (DeltaWalletState s))
listWallets :: stm [WalletId]
removeWallet :: WalletId -> ExceptT ErrNoSuchWallet stm ()
initializeWallet :: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
atomically :: ()
prune :: ()
rollbackTo :: ()
readGenesisParameters :: ()
readPrivateKey :: ()
putPrivateKey :: ()
removePendingOrExpiredTx :: ()
updatePendingTxForExpiry :: ()
readLocalTxSubmissionPending :: ()
putLocalTxSubmission :: ()
getTx :: ()
readTxHistory :: ()
putTxHistory :: ()
readDelegationRewardBalance :: ()
putDelegationRewardBalance :: ()
putDelegationCertificate :: ()
isStakeKeyRegistered :: ()
readWalletMeta :: ()
putWalletMeta :: ()
listCheckpoints :: ()
readCheckpoint :: ()
putCheckpoint :: ()
walletsDB :: ()
listWallets :: ()
removeWallet :: ()
initializeWallet :: ()
..} ->
    ctx
-> WalletId
-> Passphrase "user"
-> (ErrWithRootKey -> ErrCreateRandomAddress)
-> (k 'RootK XPrv
    -> PassphraseScheme
    -> ExceptT
         ErrCreateRandomAddress IO (Address, NonEmpty DerivationIndex))
-> ExceptT
     ErrCreateRandomAddress IO (Address, NonEmpty DerivationIndex)
forall ctx s (k :: Depth -> * -> *) e a.
HasDBLayer IO s k ctx =>
ctx
-> WalletId
-> Passphrase "user"
-> (ErrWithRootKey -> e)
-> (k 'RootK XPrv -> PassphraseScheme -> ExceptT e IO a)
-> ExceptT e IO a
withRootKey @ctx @s @k ctx
ctx WalletId
wid Passphrase "user"
pwd ErrWithRootKey -> ErrCreateRandomAddress
ErrCreateAddrWithRootKey ((k 'RootK XPrv
  -> PassphraseScheme
  -> ExceptT
       ErrCreateRandomAddress IO (Address, NonEmpty DerivationIndex))
 -> ExceptT
      ErrCreateRandomAddress IO (Address, NonEmpty DerivationIndex))
-> (k 'RootK XPrv
    -> PassphraseScheme
    -> ExceptT
         ErrCreateRandomAddress IO (Address, NonEmpty DerivationIndex))
-> ExceptT
     ErrCreateRandomAddress IO (Address, NonEmpty DerivationIndex)
forall a b. (a -> b) -> a -> b
$ \k 'RootK XPrv
xprv PassphraseScheme
scheme -> do
        IO
  (Either ErrCreateRandomAddress (Address, NonEmpty DerivationIndex))
-> ExceptT
     ErrCreateRandomAddress IO (Address, NonEmpty DerivationIndex)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO
   (Either ErrCreateRandomAddress (Address, NonEmpty DerivationIndex))
 -> ExceptT
      ErrCreateRandomAddress IO (Address, NonEmpty DerivationIndex))
-> IO
     (Either ErrCreateRandomAddress (Address, NonEmpty DerivationIndex))
-> ExceptT
     ErrCreateRandomAddress IO (Address, NonEmpty DerivationIndex)
forall a b. (a -> b) -> a -> b
$ stm
  (Either ErrCreateRandomAddress (Address, NonEmpty DerivationIndex))
-> IO
     (Either ErrCreateRandomAddress (Address, NonEmpty DerivationIndex))
forall a. stm a -> IO a
atomically (stm
   (Either ErrCreateRandomAddress (Address, NonEmpty DerivationIndex))
 -> IO
      (Either
         ErrCreateRandomAddress (Address, NonEmpty DerivationIndex)))
-> stm
     (Either ErrCreateRandomAddress (Address, NonEmpty DerivationIndex))
-> IO
     (Either ErrCreateRandomAddress (Address, NonEmpty DerivationIndex))
forall a b. (a -> b) -> a -> b
$ DBVar stm (DeltaMap WalletId (DeltaWalletState s))
-> (Map WalletId (WalletState s)
    -> (Maybe (DeltaMap WalletId (DeltaWalletState s)),
        Either ErrCreateRandomAddress (Address, NonEmpty DerivationIndex)))
-> stm
     (Either ErrCreateRandomAddress (Address, NonEmpty DerivationIndex))
forall da (m :: * -> *) a b.
(Delta da, Monad m, a ~ Base da) =>
DBVar m da -> (a -> (Maybe da, b)) -> m b
modifyDBMaybe DBVar stm (DeltaMap WalletId (DeltaWalletState s))
walletsDB ((Map WalletId (WalletState s)
  -> (Maybe (DeltaMap WalletId (DeltaWalletState s)),
      Either ErrCreateRandomAddress (Address, NonEmpty DerivationIndex)))
 -> stm
      (Either
         ErrCreateRandomAddress (Address, NonEmpty DerivationIndex)))
-> (Map WalletId (WalletState s)
    -> (Maybe (DeltaMap WalletId (DeltaWalletState s)),
        Either ErrCreateRandomAddress (Address, NonEmpty DerivationIndex)))
-> stm
     (Either ErrCreateRandomAddress (Address, NonEmpty DerivationIndex))
forall a b. (a -> b) -> a -> b
$
            WalletId
-> (ErrNoSuchWallet -> ErrCreateRandomAddress)
-> (WalletState s
    -> Either
         ErrCreateRandomAddress
         (DeltaWalletState s, (Address, NonEmpty DerivationIndex)))
-> Map WalletId (WalletState s)
-> (Maybe (DeltaMap WalletId (DeltaWalletState s)),
    Either ErrCreateRandomAddress (Address, NonEmpty DerivationIndex))
forall e w dw b.
WalletId
-> (ErrNoSuchWallet -> e)
-> (w -> Either e (dw, b))
-> Map WalletId w
-> (Maybe (DeltaMap WalletId dw), Either e b)
adjustNoSuchWallet WalletId
wid ErrNoSuchWallet -> ErrCreateRandomAddress
ErrCreateAddrNoSuchWallet ((WalletState s
  -> Either
       ErrCreateRandomAddress
       (DeltaWalletState s, (Address, NonEmpty DerivationIndex)))
 -> Map WalletId (WalletState s)
 -> (Maybe (DeltaMap WalletId (DeltaWalletState s)),
     Either ErrCreateRandomAddress (Address, NonEmpty DerivationIndex)))
-> (WalletState s
    -> Either
         ErrCreateRandomAddress
         (DeltaWalletState s, (Address, NonEmpty DerivationIndex)))
-> Map WalletId (WalletState s)
-> (Maybe (DeltaMap WalletId (DeltaWalletState s)),
    Either ErrCreateRandomAddress (Address, NonEmpty DerivationIndex))
forall a b. (a -> b) -> a -> b
$
                ByronKey 'RootK XPrv
-> PassphraseScheme
-> WalletState s
-> Either
     ErrCreateRandomAddress
     (DeltaWalletState s, (Address, NonEmpty DerivationIndex))
createRandomAddress' k 'RootK XPrv
ByronKey 'RootK XPrv
xprv PassphraseScheme
scheme
  where
    db :: DBLayer IO s k
db = ctx
ctx ctx
-> ((DBLayer IO s k -> Const (DBLayer IO s k) (DBLayer IO s k))
    -> ctx -> Const (DBLayer IO s k) ctx)
-> DBLayer IO s k
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx. HasDBLayer IO s k ctx => Lens' ctx (DBLayer IO s k)
forall (m :: * -> *) s (k :: Depth -> * -> *) ctx.
HasDBLayer m s k ctx =>
Lens' ctx (DBLayer m s k)
dbLayer @IO @s @k

    createRandomAddress' :: ByronKey 'RootK XPrv
-> PassphraseScheme
-> WalletState s
-> Either
     ErrCreateRandomAddress
     (DeltaWalletState s, (Address, NonEmpty DerivationIndex))
createRandomAddress' ByronKey 'RootK XPrv
xprv PassphraseScheme
scheme WalletState s
wal = case Maybe (Index 'Hardened 'AddressK)
mIx of
        Just Index 'Hardened 'AddressK
addrIx | Index 'Hardened 'AddressK -> s -> Bool
isKnownIndex Index 'Hardened 'AddressK
addrIx s
s0 ->
            ErrCreateRandomAddress
-> Either
     ErrCreateRandomAddress
     (DeltaWalletState s, (Address, NonEmpty DerivationIndex))
forall a b. a -> Either a b
Left (ErrCreateRandomAddress
 -> Either
      ErrCreateRandomAddress
      (DeltaWalletState s, (Address, NonEmpty DerivationIndex)))
-> ErrCreateRandomAddress
-> Either
     ErrCreateRandomAddress
     (DeltaWalletState s, (Address, NonEmpty DerivationIndex))
forall a b. (a -> b) -> a -> b
$ Index 'Hardened 'AddressK -> ErrCreateRandomAddress
ErrIndexAlreadyExists Index 'Hardened 'AddressK
addrIx
        Just Index 'Hardened 'AddressK
addrIx ->
            (DeltaWalletState s, (Address, NonEmpty DerivationIndex))
-> Either
     ErrCreateRandomAddress
     (DeltaWalletState s, (Address, NonEmpty DerivationIndex))
forall a b. b -> Either a b
Right ((DeltaWalletState s, (Address, NonEmpty DerivationIndex))
 -> Either
      ErrCreateRandomAddress
      (DeltaWalletState s, (Address, NonEmpty DerivationIndex)))
-> (DeltaWalletState s, (Address, NonEmpty DerivationIndex))
-> Either
     ErrCreateRandomAddress
     (DeltaWalletState s, (Address, NonEmpty DerivationIndex))
forall a b. (a -> b) -> a -> b
$ (DerivationPath, s)
-> (DeltaWalletState s, (Address, NonEmpty DerivationIndex))
addAddress ((Index 'Hardened 'AccountK -> Index 'WholeDomain 'AccountK
forall (derivation :: DerivationType) (level :: Depth).
LiftIndex derivation =>
Index derivation level -> Index 'WholeDomain level
liftIndex Index 'Hardened 'AccountK
accIx, Index 'Hardened 'AddressK -> Index 'WholeDomain 'AddressK
forall (derivation :: DerivationType) (level :: Depth).
LiftIndex derivation =>
Index derivation level -> Index 'WholeDomain level
liftIndex Index 'Hardened 'AddressK
addrIx), s
s0)
        Maybe (Index 'Hardened 'AddressK)
Nothing ->
            (DeltaWalletState s, (Address, NonEmpty DerivationIndex))
-> Either
     ErrCreateRandomAddress
     (DeltaWalletState s, (Address, NonEmpty DerivationIndex))
forall a b. b -> Either a b
Right ((DeltaWalletState s, (Address, NonEmpty DerivationIndex))
 -> Either
      ErrCreateRandomAddress
      (DeltaWalletState s, (Address, NonEmpty DerivationIndex)))
-> (DeltaWalletState s, (Address, NonEmpty DerivationIndex))
-> Either
     ErrCreateRandomAddress
     (DeltaWalletState s, (Address, NonEmpty DerivationIndex))
forall a b. (a -> b) -> a -> b
$ (DerivationPath, s)
-> (DeltaWalletState s, (Address, NonEmpty DerivationIndex))
addAddress ((DerivationPath, s)
 -> (DeltaWalletState s, (Address, NonEmpty DerivationIndex)))
-> (DerivationPath, s)
-> (DeltaWalletState s, (Address, NonEmpty DerivationIndex))
forall a b. (a -> b) -> a -> b
$ s -> (StdGen -> (DerivationPath, StdGen)) -> (DerivationPath, s)
forall s a.
RndStateLike s =>
s -> (StdGen -> (a, StdGen)) -> (a, s)
Rnd.withRNG s
s0 ((StdGen -> (DerivationPath, StdGen)) -> (DerivationPath, s))
-> (StdGen -> (DerivationPath, StdGen)) -> (DerivationPath, s)
forall a b. (a -> b) -> a -> b
$ \StdGen
rng ->
                StdGen
-> Index 'Hardened 'AccountK
-> Set DerivationPath
-> (DerivationPath, StdGen)
Rnd.findUnusedPath StdGen
rng Index 'Hardened 'AccountK
accIx (s -> Set DerivationPath
forall s. RndStateLike s => s -> Set DerivationPath
Rnd.unavailablePaths s
s0)
      where
        s0 :: s
s0 = Wallet s -> s
forall s. Wallet s -> s
getState (Wallet s -> s) -> Wallet s -> s
forall a b. (a -> b) -> a -> b
$ WalletState s -> Wallet s
forall s. AddressBookIso s => WalletState s -> Wallet s
getLatest WalletState s
wal
        accIx :: Index 'Hardened 'AccountK
accIx = s -> Index 'Hardened 'AccountK
forall s. RndStateLike s => s -> Index 'Hardened 'AccountK
Rnd.defaultAccountIndex s
s0
        isKnownIndex :: Index 'Hardened 'AddressK -> s -> Bool
isKnownIndex Index 'Hardened 'AddressK
addrIx s
s =
            (Index 'Hardened 'AccountK -> Index 'WholeDomain 'AccountK
forall (derivation :: DerivationType) (level :: Depth).
LiftIndex derivation =>
Index derivation level -> Index 'WholeDomain level
liftIndex Index 'Hardened 'AccountK
accIx, Index 'Hardened 'AddressK -> Index 'WholeDomain 'AddressK
forall (derivation :: DerivationType) (level :: Depth).
LiftIndex derivation =>
Index derivation level -> Index 'WholeDomain level
liftIndex Index 'Hardened 'AddressK
addrIx) DerivationPath -> Set DerivationPath -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` s -> Set DerivationPath
forall s. RndStateLike s => s -> Set DerivationPath
Rnd.unavailablePaths s
s

        addAddress :: (DerivationPath, s)
-> (DeltaWalletState s, (Address, NonEmpty DerivationIndex))
addAddress (DerivationPath
path, s
s1) =
            ( [ Prologue s -> DeltaWalletState1 s
forall s. Prologue s -> DeltaWalletState1 s
ReplacePrologue (Prologue s -> DeltaWalletState1 s)
-> Prologue s -> DeltaWalletState1 s
forall a b. (a -> b) -> a -> b
$ s -> Prologue s
forall s. AddressBookIso s => s -> Prologue s
getPrologue (s -> Prologue s) -> s -> Prologue s
forall a b. (a -> b) -> a -> b
$ Address -> DerivationPath -> s -> s
forall s. RndStateLike s => Address -> DerivationPath -> s -> s
Rnd.addPendingAddress Address
addr DerivationPath
path s
s1 ]
            , (Address
addr, DerivationPath -> NonEmpty DerivationIndex
Rnd.toDerivationIndexes DerivationPath
path)
            )
          where
            prepared :: Passphrase "encryption"
prepared = PassphraseScheme -> Passphrase "user" -> Passphrase "encryption"
preparePassphrase PassphraseScheme
scheme Passphrase "user"
pwd
            addr :: Address
addr = ByronKey 'RootK XPrv
-> Passphrase "encryption" -> DerivationPath -> Address
forall (n :: NetworkDiscriminant).
PaymentAddress n ByronKey =>
ByronKey 'RootK XPrv
-> Passphrase "encryption" -> DerivationPath -> Address
Rnd.deriveRndStateAddress @n ByronKey 'RootK XPrv
xprv Passphrase "encryption"
prepared DerivationPath
path

importRandomAddresses
    :: forall ctx s k.
        ( HasDBLayer IO s k ctx
        , RndStateLike s
        , k ~ ByronKey
        , AddressBookIso s
        )
    => ctx
    -> WalletId
    -> [Address]
    -> ExceptT ErrImportRandomAddress IO ()
importRandomAddresses :: ctx
-> WalletId -> [Address] -> ExceptT ErrImportRandomAddress IO ()
importRandomAddresses ctx
ctx WalletId
wid [Address]
addrs = DBLayer IO s k
db DBLayer IO s k
-> (DBLayer IO s k -> ExceptT ErrImportRandomAddress IO ())
-> ExceptT ErrImportRandomAddress IO ()
forall a b. a -> (a -> b) -> b
& \DBLayer{stm [WalletId]
DBVar stm (DeltaMap WalletId (DeltaWalletState s))
WalletId -> stm [LocalTxSubmissionStatus SealedTx]
WalletId -> stm [ChainPoint]
WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
WalletId -> stm (Maybe GenesisParameters)
WalletId -> stm (Maybe WalletMetadata)
WalletId -> stm (Maybe (Wallet s))
WalletId -> stm Coin
WalletId -> ExceptT ErrNoSuchWallet stm Bool
WalletId -> ExceptT ErrNoSuchWallet stm ()
WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
forall a. stm a -> IO a
atomically :: forall a. stm a -> IO a
prune :: WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
rollbackTo :: WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
readGenesisParameters :: WalletId -> stm (Maybe GenesisParameters)
readPrivateKey :: WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
putPrivateKey :: WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
removePendingOrExpiredTx :: WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
updatePendingTxForExpiry :: WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
readLocalTxSubmissionPending :: WalletId -> stm [LocalTxSubmissionStatus SealedTx]
putLocalTxSubmission :: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
getTx :: WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
readTxHistory :: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
putTxHistory :: WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
readDelegationRewardBalance :: WalletId -> stm Coin
putDelegationRewardBalance :: WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
putDelegationCertificate :: WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
isStakeKeyRegistered :: WalletId -> ExceptT ErrNoSuchWallet stm Bool
readWalletMeta :: WalletId -> stm (Maybe WalletMetadata)
putWalletMeta :: WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
listCheckpoints :: WalletId -> stm [ChainPoint]
readCheckpoint :: WalletId -> stm (Maybe (Wallet s))
putCheckpoint :: WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
walletsDB :: DBVar stm (DeltaMap WalletId (DeltaWalletState s))
listWallets :: stm [WalletId]
removeWallet :: WalletId -> ExceptT ErrNoSuchWallet stm ()
initializeWallet :: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
atomically :: ()
prune :: ()
rollbackTo :: ()
readGenesisParameters :: ()
readPrivateKey :: ()
putPrivateKey :: ()
removePendingOrExpiredTx :: ()
updatePendingTxForExpiry :: ()
readLocalTxSubmissionPending :: ()
putLocalTxSubmission :: ()
getTx :: ()
readTxHistory :: ()
putTxHistory :: ()
readDelegationRewardBalance :: ()
putDelegationRewardBalance :: ()
putDelegationCertificate :: ()
isStakeKeyRegistered :: ()
readWalletMeta :: ()
putWalletMeta :: ()
listCheckpoints :: ()
readCheckpoint :: ()
putCheckpoint :: ()
walletsDB :: ()
listWallets :: ()
removeWallet :: ()
initializeWallet :: ()
..} ->
    IO (Either ErrImportRandomAddress ())
-> ExceptT ErrImportRandomAddress IO ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ErrImportRandomAddress ())
 -> ExceptT ErrImportRandomAddress IO ())
-> IO (Either ErrImportRandomAddress ())
-> ExceptT ErrImportRandomAddress IO ()
forall a b. (a -> b) -> a -> b
$ stm (Either ErrImportRandomAddress ())
-> IO (Either ErrImportRandomAddress ())
forall a. stm a -> IO a
atomically (stm (Either ErrImportRandomAddress ())
 -> IO (Either ErrImportRandomAddress ()))
-> stm (Either ErrImportRandomAddress ())
-> IO (Either ErrImportRandomAddress ())
forall a b. (a -> b) -> a -> b
$ DBVar stm (DeltaMap WalletId (DeltaWalletState s))
-> (Map WalletId (WalletState s)
    -> (Maybe (DeltaMap WalletId (DeltaWalletState s)),
        Either ErrImportRandomAddress ()))
-> stm (Either ErrImportRandomAddress ())
forall da (m :: * -> *) a b.
(Delta da, Monad m, a ~ Base da) =>
DBVar m da -> (a -> (Maybe da, b)) -> m b
modifyDBMaybe DBVar stm (DeltaMap WalletId (DeltaWalletState s))
walletsDB ((Map WalletId (WalletState s)
  -> (Maybe (DeltaMap WalletId (DeltaWalletState s)),
      Either ErrImportRandomAddress ()))
 -> stm (Either ErrImportRandomAddress ()))
-> (Map WalletId (WalletState s)
    -> (Maybe (DeltaMap WalletId (DeltaWalletState s)),
        Either ErrImportRandomAddress ()))
-> stm (Either ErrImportRandomAddress ())
forall a b. (a -> b) -> a -> b
$
        WalletId
-> (ErrNoSuchWallet -> ErrImportRandomAddress)
-> (WalletState s
    -> Either ErrImportRandomAddress (DeltaWalletState s, ()))
-> Map WalletId (WalletState s)
-> (Maybe (DeltaMap WalletId (DeltaWalletState s)),
    Either ErrImportRandomAddress ())
forall e w dw b.
WalletId
-> (ErrNoSuchWallet -> e)
-> (w -> Either e (dw, b))
-> Map WalletId w
-> (Maybe (DeltaMap WalletId dw), Either e b)
adjustNoSuchWallet WalletId
wid ErrNoSuchWallet -> ErrImportRandomAddress
ErrImportAddrNoSuchWallet
            WalletState s
-> Either ErrImportRandomAddress (DeltaWalletState s, ())
importRandomAddresses'
  where
    db :: DBLayer IO s k
db = ctx
ctx ctx
-> ((DBLayer IO s k -> Const (DBLayer IO s k) (DBLayer IO s k))
    -> ctx -> Const (DBLayer IO s k) ctx)
-> DBLayer IO s k
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx. HasDBLayer IO s k ctx => Lens' ctx (DBLayer IO s k)
forall (m :: * -> *) s (k :: Depth -> * -> *) ctx.
HasDBLayer m s k ctx =>
Lens' ctx (DBLayer m s k)
dbLayer @IO @s @k
    importRandomAddresses' :: WalletState s
-> Either ErrImportRandomAddress (DeltaWalletState s, ())
importRandomAddresses' WalletState s
wal = case Either ErrImportAddress s
es1 of
        Left ErrImportAddress
err -> ErrImportRandomAddress
-> Either ErrImportRandomAddress (DeltaWalletState s, ())
forall a b. a -> Either a b
Left (ErrImportRandomAddress
 -> Either ErrImportRandomAddress (DeltaWalletState s, ()))
-> ErrImportRandomAddress
-> Either ErrImportRandomAddress (DeltaWalletState s, ())
forall a b. (a -> b) -> a -> b
$ ErrImportAddress -> ErrImportRandomAddress
ErrImportAddr ErrImportAddress
err
        Right s
s1 -> (DeltaWalletState s, ())
-> Either ErrImportRandomAddress (DeltaWalletState s, ())
forall a b. b -> Either a b
Right ([ Prologue s -> DeltaWalletState1 s
forall s. Prologue s -> DeltaWalletState1 s
ReplacePrologue (Prologue s -> DeltaWalletState1 s)
-> Prologue s -> DeltaWalletState1 s
forall a b. (a -> b) -> a -> b
$ s -> Prologue s
forall s. AddressBookIso s => s -> Prologue s
getPrologue s
s1 ], ())
      where
        s0 :: s
s0  = Wallet s -> s
forall s. Wallet s -> s
getState (Wallet s -> s) -> Wallet s -> s
forall a b. (a -> b) -> a -> b
$ WalletState s -> Wallet s
forall s. AddressBookIso s => WalletState s -> Wallet s
getLatest WalletState s
wal
        es1 :: Either ErrImportAddress s
es1 = (Either ErrImportAddress s -> Address -> Either ErrImportAddress s)
-> Either ErrImportAddress s
-> [Address]
-> Either ErrImportAddress s
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Either ErrImportAddress s
s Address
addr -> Either ErrImportAddress s
s Either ErrImportAddress s
-> (s -> Either ErrImportAddress s) -> Either ErrImportAddress s
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Address -> s -> Either ErrImportAddress s
forall s.
RndStateLike s =>
Address -> s -> Either ErrImportAddress s
Rnd.importAddress Address
addr) (s -> Either ErrImportAddress s
forall a b. b -> Either a b
Right s
s0) [Address]
addrs

-- NOTE
-- Addresses coming from the transaction history might be payment or
-- delegation addresses. So we normalize them all to be delegation addresses
-- to make sure that we compare them correctly.
normalizeDelegationAddress
    :: forall s k n.
        ( DelegationAddress n k
        , s ~ SeqState n k
        )
    => s
    -> Address
    -> Maybe Address
normalizeDelegationAddress :: s -> Address -> Maybe Address
normalizeDelegationAddress s
s Address
addr = do
    KeyFingerprint "payment" k
fingerprint <- Either (ErrMkKeyFingerprint k Address) (KeyFingerprint "payment" k)
-> Maybe (KeyFingerprint "payment" k)
forall a b. Either a b -> Maybe b
eitherToMaybe (Address
-> Either
     (ErrMkKeyFingerprint k Address) (KeyFingerprint "payment" k)
forall (key :: Depth -> * -> *) from.
MkKeyFingerprint key from =>
from
-> Either
     (ErrMkKeyFingerprint key from) (KeyFingerprint "payment" key)
paymentKeyFingerprint Address
addr)
    Address -> Maybe Address
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Address -> Maybe Address) -> Address -> Maybe Address
forall a b. (a -> b) -> a -> b
$ KeyFingerprint "payment" k -> k 'AddressK XPub -> Address
forall (network :: NetworkDiscriminant) (key :: Depth -> * -> *).
DelegationAddress network key =>
KeyFingerprint "payment" key -> key 'AddressK XPub -> Address
liftDelegationAddress @n KeyFingerprint "payment" k
fingerprint (k 'AddressK XPub -> Address) -> k 'AddressK XPub -> Address
forall a b. (a -> b) -> a -> b
$ SeqState n k -> k 'AddressK XPub
forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
SeqState n k -> k 'AddressK XPub
Seq.rewardAccountKey s
SeqState n k
s

{-------------------------------------------------------------------------------
                                  Transaction
-------------------------------------------------------------------------------}

-- | A 'PartialTx' is an an unbalanced 'SealedTx' along with the necessary
-- information to balance it.
--
-- The 'inputs' and 'redeemers' must match the binary transaction contained in
-- the 'sealedTx'.
data PartialTx era = PartialTx
    { PartialTx era -> Tx era
tx :: Cardano.Tx era
    , PartialTx era -> [(TxIn, TxOut, Maybe (Hash "Datum"))]
inputs :: [(TxIn, TxOut, Maybe (Hash "Datum"))]
    , PartialTx era -> [Redeemer]
redeemers :: [Redeemer]
    } deriving (Int -> PartialTx era -> ShowS
[PartialTx era] -> ShowS
PartialTx era -> String
(Int -> PartialTx era -> ShowS)
-> (PartialTx era -> String)
-> ([PartialTx era] -> ShowS)
-> Show (PartialTx era)
forall era. Int -> PartialTx era -> ShowS
forall era. [PartialTx era] -> ShowS
forall era. PartialTx era -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PartialTx era] -> ShowS
$cshowList :: forall era. [PartialTx era] -> ShowS
show :: PartialTx era -> String
$cshow :: forall era. PartialTx era -> String
showsPrec :: Int -> PartialTx era -> ShowS
$cshowsPrec :: forall era. Int -> PartialTx era -> ShowS
Show, (forall x. PartialTx era -> Rep (PartialTx era) x)
-> (forall x. Rep (PartialTx era) x -> PartialTx era)
-> Generic (PartialTx era)
forall x. Rep (PartialTx era) x -> PartialTx era
forall x. PartialTx era -> Rep (PartialTx era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (PartialTx era) x -> PartialTx era
forall era x. PartialTx era -> Rep (PartialTx era) x
$cto :: forall era x. Rep (PartialTx era) x -> PartialTx era
$cfrom :: forall era x. PartialTx era -> Rep (PartialTx era) x
Generic, PartialTx era -> PartialTx era -> Bool
(PartialTx era -> PartialTx era -> Bool)
-> (PartialTx era -> PartialTx era -> Bool) -> Eq (PartialTx era)
forall era. PartialTx era -> PartialTx era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PartialTx era -> PartialTx era -> Bool
$c/= :: forall era. PartialTx era -> PartialTx era -> Bool
== :: PartialTx era -> PartialTx era -> Bool
$c== :: forall era. PartialTx era -> PartialTx era -> Bool
Eq)

instance Buildable (PartialTx era) where
    build :: PartialTx era -> Builder
build (PartialTx Tx era
tx [(TxIn, TxOut, Maybe (Hash "Datum"))]
ins [Redeemer]
redeemers) = Builder -> Builder -> Builder
nameF Builder
"PartialTx" (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
        [ Builder -> Builder -> Builder
nameF Builder
"inputs" (((TxIn, TxOut, Maybe (Hash "Datum")) -> Builder)
-> [(TxIn, TxOut, Maybe (Hash "Datum"))] -> Builder
forall (f :: * -> *) a.
Foldable f =>
(a -> Builder) -> f a -> Builder
listF' (TxIn, TxOut, Maybe (Hash "Datum")) -> Builder
inF [(TxIn, TxOut, Maybe (Hash "Datum"))]
ins)
        , Builder -> Builder -> Builder
nameF Builder
"redeemers" ([Redeemer] -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty [Redeemer]
redeemers)
        , Builder -> Builder -> Builder
nameF Builder
"tx" (Tx era -> Builder
cardanoTxF Tx era
tx)
        ]
      where
        inF :: (TxIn, TxOut, Maybe (Hash "Datum")) -> Builder
        inF :: (TxIn, TxOut, Maybe (Hash "Datum")) -> Builder
inF (TxIn
i,TxOut
o,Maybe (Hash "Datum")
d) = Builder
""Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+|TxIn
iTxIn -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+Builder
" "Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+|TxOut
oTxOut -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+Builder
" "Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+|Maybe (Hash "Datum")
dMaybe (Hash "Datum") -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+Builder
""

        cardanoTxF :: Cardano.Tx era -> Builder
        cardanoTxF :: Tx era -> Builder
cardanoTxF Tx era
tx' = Text -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty (Text -> Builder) -> Text -> Builder
forall a b. (a -> b) -> a -> b
$ Tx era -> Text
forall a. Show a => a -> Text
pShow Tx era
tx'

balanceTransaction
    :: forall era m s k ctx.
        ( HasTransactionLayer k ctx
        , GenChange s
        , MonadRandom m
        , HasLogger m WalletWorkerLog ctx
        , Cardano.IsShelleyBasedEra era
        , BoundedAddressLength k
        )
    => ctx
    -> ArgGenChange s
    -> (W.ProtocolParameters, Cardano.ProtocolParameters)
    -> TimeInterpreter (Either PastHorizonException)
    -> (UTxOIndex WalletUTxO, Wallet s, Set Tx)
    -> PartialTx era
    -> ExceptT ErrBalanceTx m (Cardano.Tx era)
balanceTransaction :: ctx
-> ArgGenChange s
-> (ProtocolParameters, ProtocolParameters)
-> TimeInterpreter (Either PastHorizonException)
-> (UTxOIndex WalletUTxO, Wallet s, Set Tx)
-> PartialTx era
-> ExceptT ErrBalanceTx m (Tx era)
balanceTransaction ctx
ctx ArgGenChange s
change (ProtocolParameters, ProtocolParameters)
pp TimeInterpreter (Either PastHorizonException)
ti (UTxOIndex WalletUTxO, Wallet s, Set Tx)
wallet PartialTx era
ptx = do
    let balanceWith :: SelectionStrategy -> ExceptT ErrBalanceTx m (Tx era)
balanceWith SelectionStrategy
strategy =
            ctx
-> ArgGenChange s
-> (ProtocolParameters, ProtocolParameters)
-> TimeInterpreter (Either PastHorizonException)
-> (UTxOIndex WalletUTxO, Wallet s, Set Tx)
-> SelectionStrategy
-> PartialTx era
-> ExceptT ErrBalanceTx m (Tx era)
forall era (m :: * -> *) s (k :: Depth -> * -> *) ctx.
(HasTransactionLayer k ctx, GenChange s, BoundedAddressLength k,
 MonadRandom m, HasLogger m WalletWorkerLog ctx,
 IsShelleyBasedEra era) =>
ctx
-> ArgGenChange s
-> (ProtocolParameters, ProtocolParameters)
-> TimeInterpreter (Either PastHorizonException)
-> (UTxOIndex WalletUTxO, Wallet s, Set Tx)
-> SelectionStrategy
-> PartialTx era
-> ExceptT ErrBalanceTx m (Tx era)
balanceTransactionWithSelectionStrategy @era @m @s @k
                ctx
ctx ArgGenChange s
change (ProtocolParameters, ProtocolParameters)
pp TimeInterpreter (Either PastHorizonException)
ti (UTxOIndex WalletUTxO, Wallet s, Set Tx)
wallet SelectionStrategy
strategy PartialTx era
ptx
    SelectionStrategy -> ExceptT ErrBalanceTx m (Tx era)
balanceWith SelectionStrategy
SelectionStrategyOptimal
        ExceptT ErrBalanceTx m (Tx era)
-> (ErrBalanceTx -> ExceptT ErrBalanceTx m (Tx era))
-> ExceptT ErrBalanceTx m (Tx era)
forall (m :: * -> *) e a e'.
Monad m =>
ExceptT e m a -> (e -> ExceptT e' m a) -> ExceptT e' m a
`catchE` \case
            ErrBalanceTx
ErrBalanceTxMaxSizeLimitExceeded
                -> SelectionStrategy -> ExceptT ErrBalanceTx m (Tx era)
balanceWith SelectionStrategy
SelectionStrategyMinimal
            ErrBalanceTx
otherErr
                -> ErrBalanceTx -> ExceptT ErrBalanceTx m (Tx era)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ErrBalanceTx
otherErr

balanceTransactionWithSelectionStrategy
    :: forall era m s k ctx.
        ( HasTransactionLayer k ctx
        , GenChange s
        , BoundedAddressLength k
        , MonadRandom m
        , HasLogger m WalletWorkerLog ctx
        , Cardano.IsShelleyBasedEra era
        )
    => ctx
    -> ArgGenChange s
    -> (W.ProtocolParameters, Cardano.ProtocolParameters)
    -> TimeInterpreter (Either PastHorizonException)
    -> (UTxOIndex WalletUTxO, Wallet s, Set Tx)
    -> SelectionStrategy
    -> PartialTx era
    -> ExceptT ErrBalanceTx m (Cardano.Tx era)
balanceTransactionWithSelectionStrategy :: ctx
-> ArgGenChange s
-> (ProtocolParameters, ProtocolParameters)
-> TimeInterpreter (Either PastHorizonException)
-> (UTxOIndex WalletUTxO, Wallet s, Set Tx)
-> SelectionStrategy
-> PartialTx era
-> ExceptT ErrBalanceTx m (Tx era)
balanceTransactionWithSelectionStrategy
    ctx
ctx
    ArgGenChange s
generateChange
    (ProtocolParameters
pp, ProtocolParameters
nodePParams)
    TimeInterpreter (Either PastHorizonException)
ti
    (UTxOIndex WalletUTxO
internalUtxoAvailable, Wallet s
wallet, Set Tx
_pendingTxs)
    SelectionStrategy
selectionStrategy
    ptx :: PartialTx era
ptx@(PartialTx Tx era
partialTx [(TxIn, TxOut, Maybe (Hash "Datum"))]
externalInputs [Redeemer]
redeemers)
    = do
    Tx era -> ExceptT ErrBalanceTx m ()
forall (m :: * -> *) era.
Monad m =>
Tx era -> ExceptT ErrBalanceTx m ()
guardExistingCollateral Tx era
partialTx
    Tx era -> ExceptT ErrBalanceTx m ()
forall (m :: * -> *) era.
Monad m =>
Tx era -> ExceptT ErrBalanceTx m ()
guardExistingTotalCollateral Tx era
partialTx
    Tx era -> ExceptT ErrBalanceTx m ()
forall (m :: * -> *) era.
Monad m =>
Tx era -> ExceptT ErrBalanceTx m ()
guardExistingReturnCollateral Tx era
partialTx
    [TxOut] -> ExceptT ErrBalanceTx m ()
forall s t s (m :: * -> *).
(HasField "coin" s t Coin Coin, HasField "tokens" s s s t,
 Monad m) =>
[s] -> ExceptT ErrBalanceTx m ()
guardZeroAdaOutputs (SealedTx -> [TxOut]
extractOutputsFromTx (SealedTx -> [TxOut]) -> SealedTx -> [TxOut]
forall a b. (a -> b) -> a -> b
$ Tx era -> SealedTx
toSealed Tx era
partialTx)
    Tx era -> ExceptT ErrBalanceTx m ()
forall (m :: * -> *) era.
Monad m =>
Tx era -> ExceptT ErrBalanceTx m ()
guardConflictingWithdrawalNetworks Tx era
partialTx

    let era :: AnyCardanoEra
era = CardanoEra era -> AnyCardanoEra
forall era. CardanoEra era -> AnyCardanoEra
Cardano.anyCardanoEra (CardanoEra era -> AnyCardanoEra)
-> CardanoEra era -> AnyCardanoEra
forall a b. (a -> b) -> a -> b
$ IsCardanoEra era => CardanoEra era
forall era. IsCardanoEra era => CardanoEra era
Cardano.cardanoEra @era

    (Value
balance0, Lovelace
minfee0) <- Tx era -> ExceptT ErrBalanceTx m (Value, Lovelace)
balanceAfterSettingMinFee Tx era
partialTx

    ([(TxIn, TxOut)]
extraInputs, [TxIn]
extraCollateral, [TxOut]
extraOutputs) <- do
        let externalSelectedUtxo :: UTxOIndex WalletUTxO
externalSelectedUtxo = [(WalletUTxO, TokenBundle)] -> UTxOIndex WalletUTxO
forall (f :: * -> *) u.
(Foldable f, Ord u) =>
f (u, TokenBundle) -> UTxOIndex u
UTxOIndex.fromSequence ([(WalletUTxO, TokenBundle)] -> UTxOIndex WalletUTxO)
-> [(WalletUTxO, TokenBundle)] -> UTxOIndex WalletUTxO
forall a b. (a -> b) -> a -> b
$
                ((TxIn, TxOut, Maybe (Hash "Datum")) -> (WalletUTxO, TokenBundle))
-> [(TxIn, TxOut, Maybe (Hash "Datum"))]
-> [(WalletUTxO, TokenBundle)]
forall a b. (a -> b) -> [a] -> [b]
map (\(TxIn
i, TxOut Address
a TokenBundle
b,Maybe (Hash "Datum")
_datumHash) -> (TxIn -> Address -> WalletUTxO
WalletUTxO TxIn
i Address
a, TokenBundle
b))
                [(TxIn, TxOut, Maybe (Hash "Datum"))]
externalInputs
        -- TODO [ADP-1544] 'externalInputs' could conflict with the actual
        -- inputs in 'partialTx'.
        --
        -- Values could be ommitted, added or conflict with the wallet and
        -- ledger UTxO sets.
        --
        -- It appears 'prop_balanceTransactionUnresolvedInputs'
        --
        -- Ideally this would at-worst result in the resulting tx being rejected
        -- by the node. However, /perhaps/:
        -- 1. Any inconsistent input resolution inside 'balanceTransaction'
        --    could lead to unexpected results like fees being burnt.
        -- 2. Incorrect resolution could could lead to phase 2 validation
        --    failures, if e.g. different coin values lead to a different amount
        --    of execution units.
        --
        -- 'prop_balanceTransactionUnresolvedInputs' show that
        -- 'balanceTransaction' fails if outputs are omitted because of
        -- 'assignScriptRedeemers'. This should make the problem (1) unlikely,
        -- but not necessarily impossible.
        --
        -- We should investigate and make sure to handle this better.

        -- NOTE: It is not possible to know the script execution cost in
        -- advance because it actually depends on the final transaction. Inputs
        -- selected as part of the fee balancing might have an influence on the
        -- execution cost.
        -- However, they are bounded so it is possible to balance the
        -- transaction considering only the maximum cost, and only after, try to
        -- adjust the change and ExUnits of each redeemer to something more
        -- sensible than the max execution cost.

        StdGenSeed
randomSeed <- ExceptT ErrBalanceTx m StdGenSeed
forall (m :: * -> *). MonadRandom m => m StdGenSeed
stdGenSeed
        let
            transform :: s -> Selection -> ([(TxIn, TxOut)], [TxIn], [TxOut])
            transform :: s -> Selection -> ([(TxIn, TxOut)], [TxIn], [TxOut])
transform s
s Selection
sel =
                let (SelectionOf TxOut
sel', s
_) = ArgGenChange s -> Selection -> s -> (SelectionOf TxOut, s)
forall s.
GenChange s =>
ArgGenChange s -> Selection -> s -> (SelectionOf TxOut, s)
assignChangeAddresses ArgGenChange s
generateChange Selection
sel s
s
                    inputs :: [(TxIn, TxOut)]
inputs = NonEmpty (TxIn, TxOut) -> [(TxIn, TxOut)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (SelectionOf TxOut
sel' SelectionOf TxOut
-> ((NonEmpty (TxIn, TxOut)
     -> Const (NonEmpty (TxIn, TxOut)) (NonEmpty (TxIn, TxOut)))
    -> SelectionOf TxOut
    -> Const (NonEmpty (TxIn, TxOut)) (SelectionOf TxOut))
-> NonEmpty (TxIn, TxOut)
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "inputs"
  ((NonEmpty (TxIn, TxOut)
    -> Const (NonEmpty (TxIn, TxOut)) (NonEmpty (TxIn, TxOut)))
   -> SelectionOf TxOut
   -> Const (NonEmpty (TxIn, TxOut)) (SelectionOf TxOut))
(NonEmpty (TxIn, TxOut)
 -> Const (NonEmpty (TxIn, TxOut)) (NonEmpty (TxIn, TxOut)))
-> SelectionOf TxOut
-> Const (NonEmpty (TxIn, TxOut)) (SelectionOf TxOut)
#inputs)
                in  ( [(TxIn, TxOut)]
inputs
                    , (TxIn, TxOut) -> TxIn
forall a b. (a, b) -> a
fst ((TxIn, TxOut) -> TxIn) -> [(TxIn, TxOut)] -> [TxIn]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SelectionOf TxOut
sel' SelectionOf TxOut
-> (([(TxIn, TxOut)] -> Const [(TxIn, TxOut)] [(TxIn, TxOut)])
    -> SelectionOf TxOut -> Const [(TxIn, TxOut)] (SelectionOf TxOut))
-> [(TxIn, TxOut)]
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "collateral"
  (([(TxIn, TxOut)] -> Const [(TxIn, TxOut)] [(TxIn, TxOut)])
   -> SelectionOf TxOut -> Const [(TxIn, TxOut)] (SelectionOf TxOut))
([(TxIn, TxOut)] -> Const [(TxIn, TxOut)] [(TxIn, TxOut)])
-> SelectionOf TxOut -> Const [(TxIn, TxOut)] (SelectionOf TxOut)
#collateral)
                    , SelectionOf TxOut
sel' SelectionOf TxOut
-> (([TxOut] -> Const [TxOut] [TxOut])
    -> SelectionOf TxOut -> Const [TxOut] (SelectionOf TxOut))
-> [TxOut]
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "change"
  (([TxOut] -> Const [TxOut] [TxOut])
   -> SelectionOf TxOut -> Const [TxOut] (SelectionOf TxOut))
([TxOut] -> Const [TxOut] [TxOut])
-> SelectionOf TxOut -> Const [TxOut] (SelectionOf TxOut)
#change
                    )

        m () -> ExceptT ErrBalanceTx m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT ErrBalanceTx m ())
-> m () -> ExceptT ErrBalanceTx m ()
forall a b. (a -> b) -> a -> b
$ Tracer m WalletLog -> WalletLog -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m WalletLog
tr (WalletLog -> m ()) -> WalletLog -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> BuildableInAnyEra PartialTx -> WalletLog
MsgSelectionForBalancingStart
            (UTxOIndex WalletUTxO -> Int
forall u. UTxOIndex u -> Int
UTxOIndex.size UTxOIndex WalletUTxO
internalUtxoAvailable)
            (CardanoEra era -> PartialTx era -> BuildableInAnyEra PartialTx
forall (tx :: * -> *) era.
(Eq (tx era), Show (tx era), Buildable (tx era)) =>
CardanoEra era -> tx era -> BuildableInAnyEra tx
BuildableInAnyEra CardanoEra era
forall era. IsCardanoEra era => CardanoEra era
Cardano.cardanoEra PartialTx era
ptx)

        let mSel :: Either (SelectionError WalletSelectionContext) Selection
mSel = AnyCardanoEra
-> [TxOut]
-> UTxOSelection WalletUTxO
-> Value
-> Lovelace
-> StdGenSeed
-> Either (SelectionError WalletSelectionContext) Selection
selectAssets'
                AnyCardanoEra
era
                (SealedTx -> [TxOut]
extractOutputsFromTx (SealedTx -> [TxOut]) -> SealedTx -> [TxOut]
forall a b. (a -> b) -> a -> b
$ Tx era -> SealedTx
toSealed Tx era
partialTx)
                ((UTxOIndex WalletUTxO, UTxOIndex WalletUTxO)
-> UTxOSelection WalletUTxO
forall u. Ord u => (UTxOIndex u, UTxOIndex u) -> UTxOSelection u
UTxOSelection.fromIndexPair
                    (UTxOIndex WalletUTxO
internalUtxoAvailable, UTxOIndex WalletUTxO
externalSelectedUtxo))
                Value
balance0
                Lovelace
minfee0
                StdGenSeed
randomSeed

        case Either (SelectionError WalletSelectionContext) Selection
mSel of
            Left SelectionError WalletSelectionContext
e -> m () -> ExceptT ErrBalanceTx m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT ErrBalanceTx m ())
-> m () -> ExceptT ErrBalanceTx m ()
forall a b. (a -> b) -> a -> b
$
                Tracer m WalletLog -> WalletLog -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m WalletLog
tr (WalletLog -> m ()) -> WalletLog -> m ()
forall a b. (a -> b) -> a -> b
$ SelectionError WalletSelectionContext -> WalletLog
MsgSelectionError SelectionError WalletSelectionContext
e
            Right Selection
sel -> m () -> ExceptT ErrBalanceTx m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT ErrBalanceTx m ())
-> m () -> ExceptT ErrBalanceTx m ()
forall a b. (a -> b) -> a -> b
$ do
                Tracer m WalletLog -> WalletLog -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m WalletLog
tr (WalletLog -> m ()) -> WalletLog -> m ()
forall a b. (a -> b) -> a -> b
$ SelectionReportSummarized -> WalletLog
MsgSelectionReportSummarized
                    (SelectionReportSummarized -> WalletLog)
-> SelectionReportSummarized -> WalletLog
forall a b. (a -> b) -> a -> b
$ Selection -> SelectionReportSummarized
makeSelectionReportSummarized Selection
sel
                Tracer m WalletLog -> WalletLog -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m WalletLog
tr (WalletLog -> m ()) -> WalletLog -> m ()
forall a b. (a -> b) -> a -> b
$ SelectionReportDetailed -> WalletLog
MsgSelectionReportDetailed
                    (SelectionReportDetailed -> WalletLog)
-> SelectionReportDetailed -> WalletLog
forall a b. (a -> b) -> a -> b
$ Selection -> SelectionReportDetailed
makeSelectionReportDetailed Selection
sel

        (SelectionError WalletSelectionContext -> ErrBalanceTx)
-> ExceptT
     (SelectionError WalletSelectionContext)
     m
     ([(TxIn, TxOut)], [TxIn], [TxOut])
-> ExceptT ErrBalanceTx m ([(TxIn, TxOut)], [TxIn], [TxOut])
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (ErrSelectAssets -> ErrBalanceTx
ErrBalanceTxSelectAssets (ErrSelectAssets -> ErrBalanceTx)
-> (SelectionError WalletSelectionContext -> ErrSelectAssets)
-> SelectionError WalletSelectionContext
-> ErrBalanceTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SelectionError WalletSelectionContext -> ErrSelectAssets
ErrSelectAssetsSelectionError)
            (ExceptT
   (SelectionError WalletSelectionContext)
   m
   ([(TxIn, TxOut)], [TxIn], [TxOut])
 -> ExceptT ErrBalanceTx m ([(TxIn, TxOut)], [TxIn], [TxOut]))
-> (Either
      (SelectionError WalletSelectionContext)
      ([(TxIn, TxOut)], [TxIn], [TxOut])
    -> ExceptT
         (SelectionError WalletSelectionContext)
         m
         ([(TxIn, TxOut)], [TxIn], [TxOut]))
-> Either
     (SelectionError WalletSelectionContext)
     ([(TxIn, TxOut)], [TxIn], [TxOut])
-> ExceptT ErrBalanceTx m ([(TxIn, TxOut)], [TxIn], [TxOut])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Either
     (SelectionError WalletSelectionContext)
     ([(TxIn, TxOut)], [TxIn], [TxOut]))
-> ExceptT
     (SelectionError WalletSelectionContext)
     m
     ([(TxIn, TxOut)], [TxIn], [TxOut])
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either
      (SelectionError WalletSelectionContext)
      ([(TxIn, TxOut)], [TxIn], [TxOut]))
 -> ExceptT
      (SelectionError WalletSelectionContext)
      m
      ([(TxIn, TxOut)], [TxIn], [TxOut]))
-> (Either
      (SelectionError WalletSelectionContext)
      ([(TxIn, TxOut)], [TxIn], [TxOut])
    -> m (Either
            (SelectionError WalletSelectionContext)
            ([(TxIn, TxOut)], [TxIn], [TxOut])))
-> Either
     (SelectionError WalletSelectionContext)
     ([(TxIn, TxOut)], [TxIn], [TxOut])
-> ExceptT
     (SelectionError WalletSelectionContext)
     m
     ([(TxIn, TxOut)], [TxIn], [TxOut])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either
  (SelectionError WalletSelectionContext)
  ([(TxIn, TxOut)], [TxIn], [TxOut])
-> m (Either
        (SelectionError WalletSelectionContext)
        ([(TxIn, TxOut)], [TxIn], [TxOut]))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
   (SelectionError WalletSelectionContext)
   ([(TxIn, TxOut)], [TxIn], [TxOut])
 -> ExceptT ErrBalanceTx m ([(TxIn, TxOut)], [TxIn], [TxOut]))
-> Either
     (SelectionError WalletSelectionContext)
     ([(TxIn, TxOut)], [TxIn], [TxOut])
-> ExceptT ErrBalanceTx m ([(TxIn, TxOut)], [TxIn], [TxOut])
forall a b. (a -> b) -> a -> b
$
                s -> Selection -> ([(TxIn, TxOut)], [TxIn], [TxOut])
transform (Wallet s -> s
forall s. Wallet s -> s
getState Wallet s
wallet) (Selection -> ([(TxIn, TxOut)], [TxIn], [TxOut]))
-> Either (SelectionError WalletSelectionContext) Selection
-> Either
     (SelectionError WalletSelectionContext)
     ([(TxIn, TxOut)], [TxIn], [TxOut])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either (SelectionError WalletSelectionContext) Selection
mSel

    -- NOTE:
    -- Once the coin selection is done, we need to
    --
    -- (a) Add selected inputs, collateral and change outputs to the transaction
    -- (b) Assign correct execution units to every redeemer
    -- (c) Correctly reference redeemed entities with redeemer pointers
    -- (d) Adjust fees and change output(s) to the new fees.
    --
    -- There's a strong assumption that modifying the fee value AND increasing
    -- the coin values of change outputs does not modify transaction fees; or
    -- more exactly, does not modify the execution units of scripts. This is in
    -- principle a fair assumption because script validators ought to be
    -- unaware of change outputs. If their execution costs increase when change
    -- output values increase, then it becomes impossible to guarantee that fee
    -- balancing will ever converge towards a fixed point. A script validator
    -- doing such a thing is considered bonkers and this is not a behavior we
    -- ought to support.

    let unsafeFromLovelace :: Lovelace -> Coin
unsafeFromLovelace (Cardano.Lovelace BlockHeight
l) = BlockHeight -> Coin
forall i. (HasCallStack, Bits i, Integral i, Show i) => i -> Coin
Coin.unsafeFromIntegral BlockHeight
l
    Tx era
candidateTx <- TxUpdate -> ExceptT ErrBalanceTx m (Tx era)
assembleTransaction (TxUpdate -> ExceptT ErrBalanceTx m (Tx era))
-> TxUpdate -> ExceptT ErrBalanceTx m (Tx era)
forall a b. (a -> b) -> a -> b
$ TxUpdate :: [(TxIn, TxOut)] -> [TxIn] -> [TxOut] -> TxFeeUpdate -> TxUpdate
TxUpdate
        { [(TxIn, TxOut)]
$sel:extraInputs:TxUpdate :: [(TxIn, TxOut)]
extraInputs :: [(TxIn, TxOut)]
extraInputs
        , [TxIn]
$sel:extraCollateral:TxUpdate :: [TxIn]
extraCollateral :: [TxIn]
extraCollateral
        , [TxOut]
$sel:extraOutputs:TxUpdate :: [TxOut]
extraOutputs :: [TxOut]
extraOutputs
        , $sel:feeUpdate:TxUpdate :: TxFeeUpdate
feeUpdate = Coin -> TxFeeUpdate
UseNewTxFee (Coin -> TxFeeUpdate) -> Coin -> TxFeeUpdate
forall a b. (a -> b) -> a -> b
$ Lovelace -> Coin
unsafeFromLovelace Lovelace
minfee0
        }


    (Value
balance, Lovelace
candidateMinFee) <- Tx era -> ExceptT ErrBalanceTx m (Value, Lovelace)
balanceAfterSettingMinFee Tx era
candidateTx
    Coin
surplus <- case Value -> Lovelace
Cardano.selectLovelace Value
balance of
        (Cardano.Lovelace BlockHeight
c)
            | BlockHeight
c BlockHeight -> BlockHeight -> Bool
forall a. Ord a => a -> a -> Bool
>= BlockHeight
0 ->
                Coin -> ExceptT ErrBalanceTx m Coin
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Coin -> ExceptT ErrBalanceTx m Coin)
-> Coin -> ExceptT ErrBalanceTx m Coin
forall a b. (a -> b) -> a -> b
$ BlockHeight -> Coin
forall i. (HasCallStack, Bits i, Integral i, Show i) => i -> Coin
Coin.unsafeFromIntegral BlockHeight
c
            | Bool
otherwise ->
                ErrBalanceTx -> ExceptT ErrBalanceTx m Coin
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (ErrBalanceTx -> ExceptT ErrBalanceTx m Coin)
-> (ErrBalanceTxInternalError -> ErrBalanceTx)
-> ErrBalanceTxInternalError
-> ExceptT ErrBalanceTx m Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrBalanceTxInternalError -> ErrBalanceTx
ErrBalanceTxInternalError (ErrBalanceTxInternalError -> ExceptT ErrBalanceTx m Coin)
-> ErrBalanceTxInternalError -> ExceptT ErrBalanceTx m Coin
forall a b. (a -> b) -> a -> b
$
                Coin -> SealedTx -> ErrBalanceTxInternalError
ErrUnderestimatedFee
                    (BlockHeight -> Coin
forall i. (HasCallStack, Bits i, Integral i, Show i) => i -> Coin
Coin.unsafeFromIntegral (-BlockHeight
c))
                    (Tx era -> SealedTx
toSealed Tx era
candidateTx)

    let feeAndChange :: TxFeeAndChange [TxOut]
feeAndChange = Coin -> [TxOut] -> TxFeeAndChange [TxOut]
forall change. Coin -> change -> TxFeeAndChange change
TxFeeAndChange
            (Lovelace -> Coin
unsafeFromLovelace Lovelace
candidateMinFee)
            ([TxOut]
extraOutputs)
    let feePolicy :: FeePolicy
feePolicy = ((FeePolicy -> Const FeePolicy FeePolicy)
 -> ProtocolParameters -> Const FeePolicy ProtocolParameters)
-> ProtocolParameters -> FeePolicy
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view (IsLabel
  "txParameters"
  ((TxParameters -> Const FeePolicy TxParameters)
   -> ProtocolParameters -> Const FeePolicy ProtocolParameters)
(TxParameters -> Const FeePolicy TxParameters)
-> ProtocolParameters -> Const FeePolicy ProtocolParameters
#txParameters ((TxParameters -> Const FeePolicy TxParameters)
 -> ProtocolParameters -> Const FeePolicy ProtocolParameters)
-> ((FeePolicy -> Const FeePolicy FeePolicy)
    -> TxParameters -> Const FeePolicy TxParameters)
-> (FeePolicy -> Const FeePolicy FeePolicy)
-> ProtocolParameters
-> Const FeePolicy ProtocolParameters
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IsLabel
  "getFeePolicy"
  ((FeePolicy -> Const FeePolicy FeePolicy)
   -> TxParameters -> Const FeePolicy TxParameters)
(FeePolicy -> Const FeePolicy FeePolicy)
-> TxParameters -> Const FeePolicy TxParameters
#getFeePolicy) ProtocolParameters
pp

    -- @distributeSurplus@ should never fail becase we have provided enough
    -- padding in @selectAssets'@.
    TxFeeAndChange Coin
updatedFee [TxOut]
updatedChange <- (ErrMoreSurplusNeeded -> ErrBalanceTx)
-> ExceptT ErrMoreSurplusNeeded m (TxFeeAndChange [TxOut])
-> ExceptT ErrBalanceTx m (TxFeeAndChange [TxOut])
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT
        (\(ErrMoreSurplusNeeded Coin
c) ->
            ErrBalanceTxInternalError -> ErrBalanceTx
ErrBalanceTxInternalError
                (ErrBalanceTxInternalError -> ErrBalanceTx)
-> ErrBalanceTxInternalError -> ErrBalanceTx
forall a b. (a -> b) -> a -> b
$ Coin -> SealedTx -> ErrBalanceTxInternalError
ErrUnderestimatedFee Coin
c (Tx era -> SealedTx
toSealed Tx era
candidateTx))
        (m (Either ErrMoreSurplusNeeded (TxFeeAndChange [TxOut]))
-> ExceptT ErrMoreSurplusNeeded m (TxFeeAndChange [TxOut])
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either ErrMoreSurplusNeeded (TxFeeAndChange [TxOut]))
 -> ExceptT ErrMoreSurplusNeeded m (TxFeeAndChange [TxOut]))
-> (Either ErrMoreSurplusNeeded (TxFeeAndChange [TxOut])
    -> m (Either ErrMoreSurplusNeeded (TxFeeAndChange [TxOut])))
-> Either ErrMoreSurplusNeeded (TxFeeAndChange [TxOut])
-> ExceptT ErrMoreSurplusNeeded m (TxFeeAndChange [TxOut])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either ErrMoreSurplusNeeded (TxFeeAndChange [TxOut])
-> m (Either ErrMoreSurplusNeeded (TxFeeAndChange [TxOut]))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrMoreSurplusNeeded (TxFeeAndChange [TxOut])
 -> ExceptT ErrMoreSurplusNeeded m (TxFeeAndChange [TxOut]))
-> Either ErrMoreSurplusNeeded (TxFeeAndChange [TxOut])
-> ExceptT ErrMoreSurplusNeeded m (TxFeeAndChange [TxOut])
forall a b. (a -> b) -> a -> b
$ TransactionLayer k SealedTx
-> FeePolicy
-> Coin
-> TxFeeAndChange [TxOut]
-> Either ErrMoreSurplusNeeded (TxFeeAndChange [TxOut])
forall (k :: Depth -> * -> *) tx.
TransactionLayer k tx
-> FeePolicy
-> Coin
-> TxFeeAndChange [TxOut]
-> Either ErrMoreSurplusNeeded (TxFeeAndChange [TxOut])
distributeSurplus TransactionLayer k SealedTx
tl FeePolicy
feePolicy Coin
surplus TxFeeAndChange [TxOut]
feeAndChange)

    Tx era -> ExceptT ErrBalanceTx m (Tx era)
guardTxSize (Tx era -> ExceptT ErrBalanceTx m (Tx era))
-> ExceptT ErrBalanceTx m (Tx era)
-> ExceptT ErrBalanceTx m (Tx era)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Tx era -> ExceptT ErrBalanceTx m (Tx era)
guardTxBalanced (Tx era -> ExceptT ErrBalanceTx m (Tx era))
-> ExceptT ErrBalanceTx m (Tx era)
-> ExceptT ErrBalanceTx m (Tx era)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (TxUpdate -> ExceptT ErrBalanceTx m (Tx era)
assembleTransaction (TxUpdate -> ExceptT ErrBalanceTx m (Tx era))
-> TxUpdate -> ExceptT ErrBalanceTx m (Tx era)
forall a b. (a -> b) -> a -> b
$ TxUpdate :: [(TxIn, TxOut)] -> [TxIn] -> [TxOut] -> TxFeeUpdate -> TxUpdate
TxUpdate
        { [(TxIn, TxOut)]
$sel:extraInputs:TxUpdate :: [(TxIn, TxOut)]
extraInputs :: [(TxIn, TxOut)]
extraInputs
        , [TxIn]
$sel:extraCollateral:TxUpdate :: [TxIn]
extraCollateral :: [TxIn]
extraCollateral
        , $sel:extraOutputs:TxUpdate :: [TxOut]
extraOutputs = [TxOut]
updatedChange
        , $sel:feeUpdate:TxUpdate :: TxFeeUpdate
feeUpdate = Coin -> TxFeeUpdate
UseNewTxFee Coin
updatedFee
        })
  where
    tl :: TransactionLayer k SealedTx
tl = ctx
ctx ctx
-> ((TransactionLayer k SealedTx
     -> Const
          (TransactionLayer k SealedTx) (TransactionLayer k SealedTx))
    -> ctx -> Const (TransactionLayer k SealedTx) ctx)
-> TransactionLayer k SealedTx
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx.
HasTransactionLayer k ctx =>
Lens' ctx (TransactionLayer k SealedTx)
forall (k :: Depth -> * -> *) ctx.
HasTransactionLayer k ctx =>
Lens' ctx (TransactionLayer k SealedTx)
transactionLayer @k
    tr :: Tracer m WalletLog
tr = (WalletLog -> WalletWorkerLog)
-> Tracer m WalletWorkerLog -> Tracer m WalletLog
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap WalletLog -> WalletWorkerLog
MsgWallet (Tracer m WalletWorkerLog -> Tracer m WalletLog)
-> Tracer m WalletWorkerLog -> Tracer m WalletLog
forall a b. (a -> b) -> a -> b
$ ctx
ctx ctx
-> ((Tracer m WalletWorkerLog
     -> Const (Tracer m WalletWorkerLog) (Tracer m WalletWorkerLog))
    -> ctx -> Const (Tracer m WalletWorkerLog) ctx)
-> Tracer m WalletWorkerLog
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall msg ctx. HasLogger m msg ctx => Lens' ctx (Tracer m msg)
forall (m :: * -> *) msg ctx.
HasLogger m msg ctx =>
Lens' ctx (Tracer m msg)
logger @m

    toSealed :: Cardano.Tx era -> SealedTx
    toSealed :: Tx era -> SealedTx
toSealed = InAnyCardanoEra Tx -> SealedTx
sealedTxFromCardano (InAnyCardanoEra Tx -> SealedTx)
-> (Tx era -> InAnyCardanoEra Tx) -> Tx era -> SealedTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CardanoEra era -> Tx era -> InAnyCardanoEra Tx
forall era (thing :: * -> *).
IsCardanoEra era =>
CardanoEra era -> thing era -> InAnyCardanoEra thing
Cardano.InAnyCardanoEra CardanoEra era
forall era. IsCardanoEra era => CardanoEra era
Cardano.cardanoEra

    guardTxSize :: Cardano.Tx era -> ExceptT ErrBalanceTx m (Cardano.Tx era)
    guardTxSize :: Tx era -> ExceptT ErrBalanceTx m (Tx era)
guardTxSize Tx era
tx = do
        let size :: TxSize
size = TransactionLayer k SealedTx
-> ProtocolParameters -> Tx era -> TxSize
forall (k :: Depth -> * -> *) tx.
TransactionLayer k tx
-> forall era.
   IsShelleyBasedEra era =>
   ProtocolParameters -> Tx era -> TxSize
estimateSignedTxSize TransactionLayer k SealedTx
tl ProtocolParameters
nodePParams Tx era
tx
        let maxSize :: TxSize
maxSize = Natural -> TxSize
TxSize
                (Natural -> TxSize)
-> (Quantity "byte" Word16 -> Natural)
-> Quantity "byte" Word16
-> TxSize
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> Natural
forall a b.
(Integral a, Integral b, IsIntSubType a b ~ 'True) =>
a -> b
intCast
                (Word16 -> Natural)
-> (Quantity "byte" Word16 -> Word16)
-> Quantity "byte" Word16
-> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Quantity "byte" Word16 -> Word16
forall (unit :: Symbol) a. Quantity unit a -> a
getQuantity
                (Quantity "byte" Word16 -> TxSize)
-> Quantity "byte" Word16 -> TxSize
forall a b. (a -> b) -> a -> b
$ ((Quantity "byte" Word16
  -> Const (Quantity "byte" Word16) (Quantity "byte" Word16))
 -> ProtocolParameters
 -> Const (Quantity "byte" Word16) ProtocolParameters)
-> ProtocolParameters -> Quantity "byte" Word16
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view (IsLabel
  "txParameters"
  ((TxParameters -> Const (Quantity "byte" Word16) TxParameters)
   -> ProtocolParameters
   -> Const (Quantity "byte" Word16) ProtocolParameters)
(TxParameters -> Const (Quantity "byte" Word16) TxParameters)
-> ProtocolParameters
-> Const (Quantity "byte" Word16) ProtocolParameters
#txParameters ((TxParameters -> Const (Quantity "byte" Word16) TxParameters)
 -> ProtocolParameters
 -> Const (Quantity "byte" Word16) ProtocolParameters)
-> ((Quantity "byte" Word16
     -> Const (Quantity "byte" Word16) (Quantity "byte" Word16))
    -> TxParameters -> Const (Quantity "byte" Word16) TxParameters)
-> (Quantity "byte" Word16
    -> Const (Quantity "byte" Word16) (Quantity "byte" Word16))
-> ProtocolParameters
-> Const (Quantity "byte" Word16) ProtocolParameters
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IsLabel
  "getTxMaxSize"
  ((Quantity "byte" Word16
    -> Const (Quantity "byte" Word16) (Quantity "byte" Word16))
   -> TxParameters -> Const (Quantity "byte" Word16) TxParameters)
(Quantity "byte" Word16
 -> Const (Quantity "byte" Word16) (Quantity "byte" Word16))
-> TxParameters -> Const (Quantity "byte" Word16) TxParameters
#getTxMaxSize) ProtocolParameters
pp
        Bool -> ExceptT ErrBalanceTx m () -> ExceptT ErrBalanceTx m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TxSize
size TxSize -> TxSize -> Bool
forall a. Ord a => a -> a -> Bool
> TxSize
maxSize) (ExceptT ErrBalanceTx m () -> ExceptT ErrBalanceTx m ())
-> ExceptT ErrBalanceTx m () -> ExceptT ErrBalanceTx m ()
forall a b. (a -> b) -> a -> b
$
            ErrBalanceTx -> ExceptT ErrBalanceTx m ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ErrBalanceTx
ErrBalanceTxMaxSizeLimitExceeded
        Tx era -> ExceptT ErrBalanceTx m (Tx era)
forall (m :: * -> *) a. Monad m => a -> m a
return Tx era
tx

    guardTxBalanced :: Cardano.Tx era -> ExceptT ErrBalanceTx m (Cardano.Tx era)
    guardTxBalanced :: Tx era -> ExceptT ErrBalanceTx m (Tx era)
guardTxBalanced Tx era
tx = do
        let bal :: Value
bal = Tx era -> Value
txBalance Tx era
tx
        if Value
bal Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
forall a. Monoid a => a
mempty
        then Tx era -> ExceptT ErrBalanceTx m (Tx era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx era
tx
        else ErrBalanceTx -> ExceptT ErrBalanceTx m (Tx era)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (ErrBalanceTx -> ExceptT ErrBalanceTx m (Tx era))
-> ErrBalanceTx -> ExceptT ErrBalanceTx m (Tx era)
forall a b. (a -> b) -> a -> b
$ ErrBalanceTxInternalError -> ErrBalanceTx
ErrBalanceTxInternalError (ErrBalanceTxInternalError -> ErrBalanceTx)
-> ErrBalanceTxInternalError -> ErrBalanceTx
forall a b. (a -> b) -> a -> b
$ Value -> ErrBalanceTxInternalError
ErrFailedBalancing Value
bal

    txBalance :: Cardano.Tx era -> Cardano.Value
    txBalance :: Tx era -> Value
txBalance Tx era
tx =
        TransactionLayer k SealedTx
-> Tx era
-> ProtocolParameters
-> UTxO
-> [(TxIn, TxOut, Maybe (Hash "Datum"))]
-> Value
forall (k :: Depth -> * -> *) tx.
TransactionLayer k tx
-> forall era.
   IsShelleyBasedEra era =>
   Tx era
   -> ProtocolParameters
   -> UTxO
   -> [(TxIn, TxOut, Maybe (Hash "Datum"))]
   -> Value
evaluateTransactionBalance TransactionLayer k SealedTx
tl Tx era
tx ProtocolParameters
nodePParams UTxO
utxo [(TxIn, TxOut, Maybe (Hash "Datum"))]
externalInputs
      where
        utxo :: UTxO
utxo = Map WalletUTxO TokenBundle -> UTxO
CS.toExternalUTxOMap (Map WalletUTxO TokenBundle -> UTxO)
-> Map WalletUTxO TokenBundle -> UTxO
forall a b. (a -> b) -> a -> b
$ UTxOIndex WalletUTxO -> Map WalletUTxO TokenBundle
forall u. UTxOIndex u -> Map u TokenBundle
UTxOIndex.toMap UTxOIndex WalletUTxO
internalUtxoAvailable

    balanceAfterSettingMinFee
        :: Cardano.Tx era
        -> ExceptT ErrBalanceTx m (Cardano.Value, Cardano.Lovelace)
    balanceAfterSettingMinFee :: Tx era -> ExceptT ErrBalanceTx m (Value, Lovelace)
balanceAfterSettingMinFee Tx era
tx = m (Either ErrBalanceTx (Value, Lovelace))
-> ExceptT ErrBalanceTx m (Value, Lovelace)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either ErrBalanceTx (Value, Lovelace))
 -> ExceptT ErrBalanceTx m (Value, Lovelace))
-> (Either ErrBalanceTx (Value, Lovelace)
    -> m (Either ErrBalanceTx (Value, Lovelace)))
-> Either ErrBalanceTx (Value, Lovelace)
-> ExceptT ErrBalanceTx m (Value, Lovelace)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either ErrBalanceTx (Value, Lovelace)
-> m (Either ErrBalanceTx (Value, Lovelace))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrBalanceTx (Value, Lovelace)
 -> ExceptT ErrBalanceTx m (Value, Lovelace))
-> Either ErrBalanceTx (Value, Lovelace)
-> ExceptT ErrBalanceTx m (Value, Lovelace)
forall a b. (a -> b) -> a -> b
$ do
        -- NOTE: evaluateMinimumFee relies on correctly estimating the required
        -- number of witnesses.
        let minfee :: Coin
minfee = TransactionLayer k SealedTx -> ProtocolParameters -> Tx era -> Coin
forall (k :: Depth -> * -> *) tx.
TransactionLayer k tx
-> forall era.
   IsShelleyBasedEra era =>
   ProtocolParameters -> Tx era -> Coin
evaluateMinimumFee TransactionLayer k SealedTx
tl ProtocolParameters
nodePParams Tx era
tx
        let update :: TxUpdate
update = [(TxIn, TxOut)] -> [TxIn] -> [TxOut] -> TxFeeUpdate -> TxUpdate
TxUpdate [] [] [] (Coin -> TxFeeUpdate
UseNewTxFee Coin
minfee)
        Tx era
tx' <- (ErrUpdateSealedTx -> ErrBalanceTx)
-> Either ErrUpdateSealedTx (Tx era)
-> Either ErrBalanceTx (Tx era)
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left ErrUpdateSealedTx -> ErrBalanceTx
ErrBalanceTxUpdateError (Either ErrUpdateSealedTx (Tx era) -> Either ErrBalanceTx (Tx era))
-> Either ErrUpdateSealedTx (Tx era)
-> Either ErrBalanceTx (Tx era)
forall a b. (a -> b) -> a -> b
$ TransactionLayer k SealedTx
-> Tx era -> TxUpdate -> Either ErrUpdateSealedTx (Tx era)
forall (k :: Depth -> * -> *) tx.
TransactionLayer k tx
-> forall era.
   IsShelleyBasedEra era =>
   Tx era -> TxUpdate -> Either ErrUpdateSealedTx (Tx era)
updateTx TransactionLayer k SealedTx
tl Tx era
tx TxUpdate
update
        let balance :: Value
balance = TransactionLayer k SealedTx
-> Tx era
-> ProtocolParameters
-> UTxO
-> [(TxIn, TxOut, Maybe (Hash "Datum"))]
-> Value
forall (k :: Depth -> * -> *) tx.
TransactionLayer k tx
-> forall era.
   IsShelleyBasedEra era =>
   Tx era
   -> ProtocolParameters
   -> UTxO
   -> [(TxIn, TxOut, Maybe (Hash "Datum"))]
   -> Value
evaluateTransactionBalance TransactionLayer k SealedTx
tl Tx era
tx' ProtocolParameters
nodePParams
                (Map WalletUTxO TokenBundle -> UTxO
CS.toExternalUTxOMap (Map WalletUTxO TokenBundle -> UTxO)
-> Map WalletUTxO TokenBundle -> UTxO
forall a b. (a -> b) -> a -> b
$ UTxOIndex WalletUTxO -> Map WalletUTxO TokenBundle
forall u. UTxOIndex u -> Map u TokenBundle
UTxOIndex.toMap UTxOIndex WalletUTxO
internalUtxoAvailable)
                ((([(TxIn, TxOut, Maybe (Hash "Datum"))]
  -> Const
       [(TxIn, TxOut, Maybe (Hash "Datum"))]
       [(TxIn, TxOut, Maybe (Hash "Datum"))])
 -> PartialTx era
 -> Const [(TxIn, TxOut, Maybe (Hash "Datum"))] (PartialTx era))
-> PartialTx era -> [(TxIn, TxOut, Maybe (Hash "Datum"))]
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "inputs"
  (([(TxIn, TxOut, Maybe (Hash "Datum"))]
    -> Const
         [(TxIn, TxOut, Maybe (Hash "Datum"))]
         [(TxIn, TxOut, Maybe (Hash "Datum"))])
   -> PartialTx era
   -> Const [(TxIn, TxOut, Maybe (Hash "Datum"))] (PartialTx era))
([(TxIn, TxOut, Maybe (Hash "Datum"))]
 -> Const
      [(TxIn, TxOut, Maybe (Hash "Datum"))]
      [(TxIn, TxOut, Maybe (Hash "Datum"))])
-> PartialTx era
-> Const [(TxIn, TxOut, Maybe (Hash "Datum"))] (PartialTx era)
#inputs PartialTx era
ptx)
        let minfee' :: Lovelace
minfee' = BlockHeight -> Lovelace
Cardano.Lovelace (BlockHeight -> Lovelace) -> BlockHeight -> Lovelace
forall a b. (a -> b) -> a -> b
$ Natural -> BlockHeight
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> BlockHeight) -> Natural -> BlockHeight
forall a b. (a -> b) -> a -> b
$ Coin -> Natural
unCoin Coin
minfee
        (Value, Lovelace) -> Either ErrBalanceTx (Value, Lovelace)
forall (m :: * -> *) a. Monad m => a -> m a
return (Value
balance, Lovelace
minfee')

    assembleTransaction
        :: TxUpdate
        -> ExceptT ErrBalanceTx m (Cardano.Tx era)
    assembleTransaction :: TxUpdate -> ExceptT ErrBalanceTx m (Tx era)
assembleTransaction TxUpdate
update = m (Either ErrBalanceTx (Tx era)) -> ExceptT ErrBalanceTx m (Tx era)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either ErrBalanceTx (Tx era))
 -> ExceptT ErrBalanceTx m (Tx era))
-> (Either ErrBalanceTx (Tx era)
    -> m (Either ErrBalanceTx (Tx era)))
-> Either ErrBalanceTx (Tx era)
-> ExceptT ErrBalanceTx m (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either ErrBalanceTx (Tx era) -> m (Either ErrBalanceTx (Tx era))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrBalanceTx (Tx era) -> ExceptT ErrBalanceTx m (Tx era))
-> Either ErrBalanceTx (Tx era) -> ExceptT ErrBalanceTx m (Tx era)
forall a b. (a -> b) -> a -> b
$ do
        Tx era
tx' <- (ErrUpdateSealedTx -> ErrBalanceTx)
-> Either ErrUpdateSealedTx (Tx era)
-> Either ErrBalanceTx (Tx era)
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left ErrUpdateSealedTx -> ErrBalanceTx
ErrBalanceTxUpdateError (Either ErrUpdateSealedTx (Tx era) -> Either ErrBalanceTx (Tx era))
-> Either ErrUpdateSealedTx (Tx era)
-> Either ErrBalanceTx (Tx era)
forall a b. (a -> b) -> a -> b
$ TransactionLayer k SealedTx
-> Tx era -> TxUpdate -> Either ErrUpdateSealedTx (Tx era)
forall (k :: Depth -> * -> *) tx.
TransactionLayer k tx
-> forall era.
   IsShelleyBasedEra era =>
   Tx era -> TxUpdate -> Either ErrUpdateSealedTx (Tx era)
updateTx TransactionLayer k SealedTx
tl Tx era
partialTx TxUpdate
update
        (ErrAssignRedeemers -> ErrBalanceTx)
-> Either ErrAssignRedeemers (Tx era)
-> Either ErrBalanceTx (Tx era)
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left ErrAssignRedeemers -> ErrBalanceTx
ErrBalanceTxAssignRedeemers (Either ErrAssignRedeemers (Tx era)
 -> Either ErrBalanceTx (Tx era))
-> Either ErrAssignRedeemers (Tx era)
-> Either ErrBalanceTx (Tx era)
forall a b. (a -> b) -> a -> b
$ TransactionLayer k SealedTx
-> ProtocolParameters
-> TimeInterpreter (Either PastHorizonException)
-> (TxIn -> Maybe (TxOut, Maybe (Hash "Datum")))
-> [Redeemer]
-> Tx era
-> Either ErrAssignRedeemers (Tx era)
forall (k :: Depth -> * -> *) tx.
TransactionLayer k tx
-> forall era.
   IsShelleyBasedEra era =>
   ProtocolParameters
   -> TimeInterpreter (Either PastHorizonException)
   -> (TxIn -> Maybe (TxOut, Maybe (Hash "Datum")))
   -> [Redeemer]
   -> Tx era
   -> Either ErrAssignRedeemers (Tx era)
assignScriptRedeemers
            TransactionLayer k SealedTx
tl ProtocolParameters
nodePParams TimeInterpreter (Either PastHorizonException)
ti TxIn -> Maybe (TxOut, Maybe (Hash "Datum"))
resolveInput [Redeemer]
redeemers Tx era
tx'
      where
        resolveInput :: TxIn -> Maybe (TxOut, Maybe (Hash "Datum"))
        resolveInput :: TxIn -> Maybe (TxOut, Maybe (Hash "Datum"))
resolveInput TxIn
i =
            (\(TxIn
_,TxOut
o,Maybe (Hash "Datum")
d) -> (TxOut
o,Maybe (Hash "Datum")
d))
                ((TxIn, TxOut, Maybe (Hash "Datum"))
 -> (TxOut, Maybe (Hash "Datum")))
-> Maybe (TxIn, TxOut, Maybe (Hash "Datum"))
-> Maybe (TxOut, Maybe (Hash "Datum"))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((TxIn, TxOut, Maybe (Hash "Datum")) -> Bool)
-> [(TxIn, TxOut, Maybe (Hash "Datum"))]
-> Maybe (TxIn, TxOut, Maybe (Hash "Datum"))
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (\(TxIn
i',TxOut
_,Maybe (Hash "Datum")
_) -> TxIn
i TxIn -> TxIn -> Bool
forall a. Eq a => a -> a -> Bool
== TxIn
i') [(TxIn, TxOut, Maybe (Hash "Datum"))]
externalInputs
            Maybe (TxOut, Maybe (Hash "Datum"))
-> Maybe (TxOut, Maybe (Hash "Datum"))
-> Maybe (TxOut, Maybe (Hash "Datum"))
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
            (\(TxIn
_,TxOut
o) -> (TxOut
o, Maybe (Hash "Datum")
forall a. Maybe a
Nothing))
                ((TxIn, TxOut) -> (TxOut, Maybe (Hash "Datum")))
-> Maybe (TxIn, TxOut) -> Maybe (TxOut, Maybe (Hash "Datum"))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((TxIn, TxOut) -> Bool) -> [(TxIn, TxOut)] -> Maybe (TxIn, TxOut)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (\(TxIn
i',TxOut
_) -> TxIn
i TxIn -> TxIn -> Bool
forall a. Eq a => a -> a -> Bool
== TxIn
i') (TxUpdate -> [(TxIn, TxOut)]
extraInputs TxUpdate
update)

    guardZeroAdaOutputs :: [s] -> ExceptT ErrBalanceTx m ()
guardZeroAdaOutputs [s]
outputs = do
        -- We seem to produce imbalanced transactions if zero-ada
        -- outputs are pre-specified. Example from
        -- 'prop_balanceTransactionBalanced':
        --
        -- balanced tx:
        --  2afeed9b
        --  []
        --  inputs 2nd 01f4b788
        --  outputs address: 82d81858...6f57b300
        --          coin: 0.000000
        --          tokens: []
        --  []
        --  metadata:
        --  scriptValidity: valid

        --  Lovelace 1000000 /= Lovelace 0
        --
        --  This is probably due to selectAssets replacing 0 ada outputs with
        --  minUTxOValue in the selection, which doesn't end up in the CBOR tx.
        let zeroAdaOutputs :: [s]
zeroAdaOutputs =
                (s -> Bool) -> [s] -> [s]
forall a. (a -> Bool) -> [a] -> [a]
filter (\s
o -> ((Coin -> Const Coin Coin) -> s -> Const Coin s) -> s -> Coin
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view (IsLabel "tokens" ((s -> Const Coin t) -> s -> Const Coin s)
(s -> Const Coin t) -> s -> Const Coin s
#tokens ((s -> Const Coin t) -> s -> Const Coin s)
-> ((Coin -> Const Coin Coin) -> s -> Const Coin t)
-> (Coin -> Const Coin Coin)
-> s
-> Const Coin s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IsLabel "coin" ((Coin -> Const Coin Coin) -> s -> Const Coin t)
(Coin -> Const Coin Coin) -> s -> Const Coin t
#coin) s
o Coin -> Coin -> Bool
forall a. Eq a => a -> a -> Bool
== Natural -> Coin
Coin Natural
0 ) [s]
outputs

        Bool -> ExceptT ErrBalanceTx m () -> ExceptT ErrBalanceTx m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([s] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [s]
zeroAdaOutputs) (ExceptT ErrBalanceTx m () -> ExceptT ErrBalanceTx m ())
-> ExceptT ErrBalanceTx m () -> ExceptT ErrBalanceTx m ()
forall a b. (a -> b) -> a -> b
$
            ErrBalanceTx -> ExceptT ErrBalanceTx m ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ErrBalanceTx
ErrBalanceTxZeroAdaOutput

    extractOutputsFromTx :: SealedTx -> [TxOut]
extractOutputsFromTx SealedTx
tx =
        let
            era :: AnyCardanoEra
era = CardanoEra era -> AnyCardanoEra
forall era. IsCardanoEra era => CardanoEra era -> AnyCardanoEra
Cardano.AnyCardanoEra (CardanoEra era -> AnyCardanoEra)
-> CardanoEra era -> AnyCardanoEra
forall a b. (a -> b) -> a -> b
$ IsCardanoEra era => CardanoEra era
forall era. IsCardanoEra era => CardanoEra era
Cardano.cardanoEra @era
            (Tx {[TxOut]
$sel:outputs:Tx :: Tx -> [TxOut]
outputs :: [TxOut]
outputs}, TokenMapWithScripts
_, TokenMapWithScripts
_, [Certificate]
_, Maybe ValidityIntervalExplicit
_) = TransactionLayer k SealedTx
-> AnyCardanoEra
-> SealedTx
-> (Tx, TokenMapWithScripts, TokenMapWithScripts, [Certificate],
    Maybe ValidityIntervalExplicit)
forall (k :: Depth -> * -> *) tx.
TransactionLayer k tx
-> AnyCardanoEra
-> tx
-> (Tx, TokenMapWithScripts, TokenMapWithScripts, [Certificate],
    Maybe ValidityIntervalExplicit)
decodeTx TransactionLayer k SealedTx
tl AnyCardanoEra
era SealedTx
tx
        in [TxOut]
outputs

    guardConflictingWithdrawalNetworks :: Tx era -> ExceptT ErrBalanceTx m ()
guardConflictingWithdrawalNetworks
        (Cardano.Tx (Cardano.TxBody TxBodyContent ViewTx era
body) [KeyWitness era]
_) = do
        -- Use of withdrawals with different networks breaks balancing.
        --
        -- For instance the partial tx might contain two withdrawals with the
        -- same key but different networks:
        -- [ (Mainnet, pkh1, coin1)
        -- , (Testnet, pkh1, coin2)
        -- ]
        --
        -- Even though this is absurd, the node/ledger
        -- @evaluateTransactionBalance@ will count @coin1+coin2@ towards the
        -- total balance. Because the wallet does not consider the network tag,
        -- it will drop one of the two, leading to a discrepancy.
        let networkOfWdrl :: (StakeAddress, b, c) -> Network
networkOfWdrl ((Cardano.StakeAddress Network
nw StakeCredential StandardCrypto
_), b
_, c
_) = Network
nw
        let conflictingWdrlNetworks :: Bool
conflictingWdrlNetworks = case TxBodyContent ViewTx era -> TxWithdrawals ViewTx era
forall build era.
TxBodyContent build era -> TxWithdrawals build era
Cardano.txWithdrawals TxBodyContent ViewTx era
body of
                TxWithdrawals ViewTx era
Cardano.TxWithdrawalsNone -> Bool
False
                Cardano.TxWithdrawals WithdrawalsSupportedInEra era
_ [(StakeAddress, Lovelace,
  BuildTxWith ViewTx (Witness WitCtxStake era))]
wdrls -> Set Network -> Int
forall a. Set a -> Int
Set.size
                    ([Network] -> Set Network
forall a. Ord a => [a] -> Set a
Set.fromList ([Network] -> Set Network) -> [Network] -> Set Network
forall a b. (a -> b) -> a -> b
$ ((StakeAddress, Lovelace,
  BuildTxWith ViewTx (Witness WitCtxStake era))
 -> Network)
-> [(StakeAddress, Lovelace,
     BuildTxWith ViewTx (Witness WitCtxStake era))]
-> [Network]
forall a b. (a -> b) -> [a] -> [b]
map (StakeAddress, Lovelace,
 BuildTxWith ViewTx (Witness WitCtxStake era))
-> Network
forall b c. (StakeAddress, b, c) -> Network
networkOfWdrl [(StakeAddress, Lovelace,
  BuildTxWith ViewTx (Witness WitCtxStake era))]
wdrls) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
        Bool -> ExceptT ErrBalanceTx m () -> ExceptT ErrBalanceTx m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
conflictingWdrlNetworks (ExceptT ErrBalanceTx m () -> ExceptT ErrBalanceTx m ())
-> ExceptT ErrBalanceTx m () -> ExceptT ErrBalanceTx m ()
forall a b. (a -> b) -> a -> b
$
            ErrBalanceTx -> ExceptT ErrBalanceTx m ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ErrBalanceTx
ErrBalanceTxConflictingNetworks

    guardExistingCollateral :: Tx era -> ExceptT ErrBalanceTx m ()
guardExistingCollateral (Cardano.Tx (Cardano.TxBody TxBodyContent ViewTx era
body) [KeyWitness era]
_) = do
        -- Coin selection does not support pre-defining collateral. In Sep 2021
        -- consensus was that we /could/ allow for it with just a day's work or
        -- so, but that the need for it was unclear enough that it was not in
        -- any way a priority.
        case TxBodyContent ViewTx era -> TxInsCollateral era
forall build era. TxBodyContent build era -> TxInsCollateral era
Cardano.txInsCollateral TxBodyContent ViewTx era
body of
            TxInsCollateral era
Cardano.TxInsCollateralNone -> () -> ExceptT ErrBalanceTx m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Cardano.TxInsCollateral CollateralSupportedInEra era
_ [] -> () -> ExceptT ErrBalanceTx m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Cardano.TxInsCollateral CollateralSupportedInEra era
_ [TxIn]
_ ->
                ErrBalanceTx -> ExceptT ErrBalanceTx m ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ErrBalanceTx
ErrBalanceTxExistingCollateral

    guardExistingTotalCollateral :: Tx era -> ExceptT ErrBalanceTx m ()
guardExistingTotalCollateral (Cardano.Tx (Cardano.TxBody TxBodyContent ViewTx era
body) [KeyWitness era]
_) =
        case TxBodyContent ViewTx era -> TxTotalCollateral era
forall build era. TxBodyContent build era -> TxTotalCollateral era
Cardano.txTotalCollateral TxBodyContent ViewTx era
body of
            TxTotalCollateral era
Cardano.TxTotalCollateralNone -> () -> ExceptT ErrBalanceTx m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Cardano.TxTotalCollateral TxTotalAndReturnCollateralSupportedInEra era
_ Lovelace
_ ->
               ErrBalanceTx -> ExceptT ErrBalanceTx m ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ErrBalanceTx
ErrBalanceTxExistingTotalCollateral

    guardExistingReturnCollateral :: Tx era -> ExceptT ErrBalanceTx m ()
guardExistingReturnCollateral (Cardano.Tx (Cardano.TxBody TxBodyContent ViewTx era
body) [KeyWitness era]
_) =
        case TxBodyContent ViewTx era -> TxReturnCollateral CtxTx era
forall build era.
TxBodyContent build era -> TxReturnCollateral CtxTx era
Cardano.txReturnCollateral TxBodyContent ViewTx era
body of
            TxReturnCollateral CtxTx era
Cardano.TxReturnCollateralNone -> () -> ExceptT ErrBalanceTx m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Cardano.TxReturnCollateral TxTotalAndReturnCollateralSupportedInEra era
_ TxOut CtxTx era
_ ->
               ErrBalanceTx -> ExceptT ErrBalanceTx m ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ErrBalanceTx
ErrBalanceTxExistingReturnCollateral

    -- | Select assets to cover the specified balance and fee.
    --
    -- If the transaction contains redeemers, the function will also ensure the
    -- selection covers the fees for the maximum allowed execution units of a
    -- transaction. For this, and other reasons, the selection may include too
    -- much ada.
    selectAssets'
        :: Cardano.AnyCardanoEra
        -> [TxOut]
        -> UTxOSelection WalletUTxO
        -- ^ Describes which utxos are pre-selected, and which can be used as
        -- inputs or collateral.
        -> Cardano.Value -- Balance to cover
        -> Cardano.Lovelace -- Current minfee (before selecting assets)
        -> StdGenSeed
        -> Either (SelectionError WalletSelectionContext) Selection
    selectAssets' :: AnyCardanoEra
-> [TxOut]
-> UTxOSelection WalletUTxO
-> Value
-> Lovelace
-> StdGenSeed
-> Either (SelectionError WalletSelectionContext) Selection
selectAssets' AnyCardanoEra
era [TxOut]
outs UTxOSelection WalletUTxO
utxoSelection Value
balance Lovelace
fee0 StdGenSeed
seed =
        let
            txPlutusScriptExecutionCost :: Coin
txPlutusScriptExecutionCost = TransactionLayer k SealedTx
-> ProtocolParameters -> [Redeemer] -> Coin
forall (k :: Depth -> * -> *) tx.
TransactionLayer k tx -> ProtocolParameters -> [Redeemer] -> Coin
maxScriptExecutionCost TransactionLayer k SealedTx
tl ProtocolParameters
pp [Redeemer]
redeemers
            colReq :: SelectionCollateralRequirement
colReq =
                if Coin
txPlutusScriptExecutionCost Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
> Natural -> Coin
Coin Natural
0 then
                    SelectionCollateralRequirement
SelectionCollateralRequired
                else
                    SelectionCollateralRequirement
SelectionCollateralNotRequired

            (TokenBundle
positiveBundle, TokenBundle
negativeBundle) = Value -> (TokenBundle, TokenBundle)
posAndNegFromCardanoValue Value
balance
            (TokenBundle Coin
positiveAda TokenMap
positiveTokens) = TokenBundle
positiveBundle
            (TokenBundle Coin
negativeAda TokenMap
negativeTokens) = TokenBundle
negativeBundle

            adaInOutputs :: Coin
adaInOutputs = (TxOut -> Coin) -> [TxOut] -> Coin
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap (TokenBundle -> Coin
TokenBundle.getCoin (TokenBundle -> Coin) -> (TxOut -> TokenBundle) -> TxOut -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TokenBundle -> Const TokenBundle TokenBundle)
 -> TxOut -> Const TokenBundle TxOut)
-> TxOut -> TokenBundle
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "tokens"
  ((TokenBundle -> Const TokenBundle TokenBundle)
   -> TxOut -> Const TokenBundle TxOut)
(TokenBundle -> Const TokenBundle TokenBundle)
-> TxOut -> Const TokenBundle TxOut
#tokens) [TxOut]
outs
            tokensInOutputs :: TokenMap
tokensInOutputs = (TxOut -> TokenMap) -> [TxOut] -> TokenMap
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap (TokenBundle -> TokenMap
TokenBundle.tokens (TokenBundle -> TokenMap)
-> (TxOut -> TokenBundle) -> TxOut -> TokenMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TokenBundle -> Const TokenBundle TokenBundle)
 -> TxOut -> Const TokenBundle TxOut)
-> TxOut -> TokenBundle
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "tokens"
  ((TokenBundle -> Const TokenBundle TokenBundle)
   -> TxOut -> Const TokenBundle TxOut)
(TokenBundle -> Const TokenBundle TokenBundle)
-> TxOut -> Const TokenBundle TxOut
#tokens) [TxOut]
outs
            tokensInInputs :: TokenMap
tokensInInputs = TokenBundle -> TokenMap
TokenBundle.tokens
                (TokenBundle -> TokenMap) -> TokenBundle -> TokenMap
forall a b. (a -> b) -> a -> b
$ UTxOSelection WalletUTxO -> TokenBundle
forall (s :: * -> *) u. IsUTxOSelection s u => s u -> TokenBundle
UTxOSelection.selectedBalance UTxOSelection WalletUTxO
utxoSelection
            adaInInputs :: Coin
adaInInputs = TokenBundle -> Coin
TokenBundle.getCoin
                (TokenBundle -> Coin) -> TokenBundle -> Coin
forall a b. (a -> b) -> a -> b
$ UTxOSelection WalletUTxO -> TokenBundle
forall (s :: * -> *) u. IsUTxOSelection s u => s u -> TokenBundle
UTxOSelection.selectedBalance UTxOSelection WalletUTxO
utxoSelection

            boringFee :: Coin
boringFee =
                let
                    boringSkeleton :: SelectionSkeleton
boringSkeleton = SelectionSkeleton :: Int -> [TxOut] -> [Set AssetId] -> SelectionSkeleton
SelectionSkeleton
                        { $sel:skeletonInputCount:SelectionSkeleton :: Int
skeletonInputCount =
                            UTxOSelection WalletUTxO -> Int
forall (s :: * -> *) u. IsUTxOSelection s u => s u -> Int
UTxOSelection.selectedSize UTxOSelection WalletUTxO
utxoSelection
                        , $sel:skeletonOutputs:SelectionSkeleton :: [TxOut]
skeletonOutputs = [TxOut]
outs
                        , $sel:skeletonChange:SelectionSkeleton :: [Set AssetId]
skeletonChange = []
                        }
                in TransactionLayer k SealedTx
-> AnyCardanoEra
-> ProtocolParameters
-> TransactionCtx
-> SelectionSkeleton
-> Coin
forall (k :: Depth -> * -> *) tx.
TransactionLayer k tx
-> AnyCardanoEra
-> ProtocolParameters
-> TransactionCtx
-> SelectionSkeleton
-> Coin
calcMinimumCost
                        TransactionLayer k SealedTx
tl
                        AnyCardanoEra
era
                        ProtocolParameters
pp
                        TransactionCtx
defaultTransactionCtx
                        SelectionSkeleton
boringSkeleton

            feePadding :: Coin
feePadding =
                let LinearFee LinearFunction {$sel:slope:LinearFunction :: forall a. LinearFunction a -> a
slope = Double
perByte} =
                        ((FeePolicy -> Const FeePolicy FeePolicy)
 -> ProtocolParameters -> Const FeePolicy ProtocolParameters)
-> ProtocolParameters -> FeePolicy
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view (IsLabel
  "txParameters"
  ((TxParameters -> Const FeePolicy TxParameters)
   -> ProtocolParameters -> Const FeePolicy ProtocolParameters)
(TxParameters -> Const FeePolicy TxParameters)
-> ProtocolParameters -> Const FeePolicy ProtocolParameters
#txParameters ((TxParameters -> Const FeePolicy TxParameters)
 -> ProtocolParameters -> Const FeePolicy ProtocolParameters)
-> ((FeePolicy -> Const FeePolicy FeePolicy)
    -> TxParameters -> Const FeePolicy TxParameters)
-> (FeePolicy -> Const FeePolicy FeePolicy)
-> ProtocolParameters
-> Const FeePolicy ProtocolParameters
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IsLabel
  "getFeePolicy"
  ((FeePolicy -> Const FeePolicy FeePolicy)
   -> TxParameters -> Const FeePolicy TxParameters)
(FeePolicy -> Const FeePolicy FeePolicy)
-> TxParameters -> Const FeePolicy TxParameters
#getFeePolicy) ProtocolParameters
pp
                    scriptIntegrityHashBytes :: Natural
scriptIntegrityHashBytes = Natural
32 Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
2

                    -- Add padding to allow the fee value to increase.
                    -- Out of caution, assume it can increase by the theoretical
                    -- maximum of 8 bytes ('maximumCostOfIncreasingCoin').
                    --
                    -- NOTE: It's not convenient to import the constant at the
                    -- moment because of the package split.
                    --
                    -- Any overestimation will be reduced by 'distributeSurplus'
                    -- in the final stage of 'balanceTransaction'.
                    extraBytes :: Natural
extraBytes = Natural
8
                in
                Natural -> Coin
Coin (Natural -> Coin) -> Natural -> Coin
forall a b. (a -> b) -> a -> b
$ (Double -> Natural
forall a b. (RealFrac a, Integral b) => a -> b
round Double
perByte) Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
* (Natural
extraBytes Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
scriptIntegrityHashBytes)

            fromCardanoLovelace :: Lovelace -> Coin
fromCardanoLovelace (Cardano.Lovelace BlockHeight
l) = BlockHeight -> Coin
forall i. (HasCallStack, Bits i, Integral i, Show i) => i -> Coin
Coin.unsafeFromIntegral BlockHeight
l

            selectionConstraints :: SelectionConstraints
selectionConstraints = SelectionConstraints :: (TokenBundle -> TokenBundleSizeAssessment)
-> Coin
-> (Address -> TokenMap -> Coin)
-> (Address -> TokenBundle -> Bool)
-> (SelectionSkeleton -> Coin)
-> ([TxOut] -> SelectionLimit)
-> Int
-> Natural
-> Address
-> SelectionConstraints
SelectionConstraints
                { $sel:assessTokenBundleSize:SelectionConstraints :: TokenBundle -> TokenBundleSizeAssessment
assessTokenBundleSize =
                    (((TokenBundle -> TokenBundleSizeAssessment)
  -> Const
       (TokenBundle -> TokenBundleSizeAssessment)
       (TokenBundle -> TokenBundleSizeAssessment))
 -> TokenBundleSizeAssessor
 -> Const
      (TokenBundle -> TokenBundleSizeAssessment) TokenBundleSizeAssessor)
-> TokenBundleSizeAssessor
-> TokenBundle
-> TokenBundleSizeAssessment
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "assessTokenBundleSize"
  (((TokenBundle -> TokenBundleSizeAssessment)
    -> Const
         (TokenBundle -> TokenBundleSizeAssessment)
         (TokenBundle -> TokenBundleSizeAssessment))
   -> TokenBundleSizeAssessor
   -> Const
        (TokenBundle -> TokenBundleSizeAssessment) TokenBundleSizeAssessor)
((TokenBundle -> TokenBundleSizeAssessment)
 -> Const
      (TokenBundle -> TokenBundleSizeAssessment)
      (TokenBundle -> TokenBundleSizeAssessment))
-> TokenBundleSizeAssessor
-> Const
     (TokenBundle -> TokenBundleSizeAssessment) TokenBundleSizeAssessor
#assessTokenBundleSize (TokenBundleSizeAssessor
 -> TokenBundle -> TokenBundleSizeAssessment)
-> TokenBundleSizeAssessor
-> TokenBundle
-> TokenBundleSizeAssessment
forall a b. (a -> b) -> a -> b
$
                    TransactionLayer k SealedTx
-> TokenBundleMaxSize -> TokenBundleSizeAssessor
forall (k :: Depth -> * -> *) tx.
TransactionLayer k tx
-> TokenBundleMaxSize -> TokenBundleSizeAssessor
tokenBundleSizeAssessor TransactionLayer k SealedTx
tl (TokenBundleMaxSize -> TokenBundleSizeAssessor)
-> TokenBundleMaxSize -> TokenBundleSizeAssessor
forall a b. (a -> b) -> a -> b
$
                    ProtocolParameters
pp ProtocolParameters
-> ((TokenBundleMaxSize
     -> Const TokenBundleMaxSize TokenBundleMaxSize)
    -> ProtocolParameters
    -> Const TokenBundleMaxSize ProtocolParameters)
-> TokenBundleMaxSize
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. (IsLabel
  "txParameters"
  ((TxParameters -> Const TokenBundleMaxSize TxParameters)
   -> ProtocolParameters
   -> Const TokenBundleMaxSize ProtocolParameters)
(TxParameters -> Const TokenBundleMaxSize TxParameters)
-> ProtocolParameters
-> Const TokenBundleMaxSize ProtocolParameters
#txParameters ((TxParameters -> Const TokenBundleMaxSize TxParameters)
 -> ProtocolParameters
 -> Const TokenBundleMaxSize ProtocolParameters)
-> ((TokenBundleMaxSize
     -> Const TokenBundleMaxSize TokenBundleMaxSize)
    -> TxParameters -> Const TokenBundleMaxSize TxParameters)
-> (TokenBundleMaxSize
    -> Const TokenBundleMaxSize TokenBundleMaxSize)
-> ProtocolParameters
-> Const TokenBundleMaxSize ProtocolParameters
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IsLabel
  "getTokenBundleMaxSize"
  ((TokenBundleMaxSize
    -> Const TokenBundleMaxSize TokenBundleMaxSize)
   -> TxParameters -> Const TokenBundleMaxSize TxParameters)
(TokenBundleMaxSize -> Const TokenBundleMaxSize TokenBundleMaxSize)
-> TxParameters -> Const TokenBundleMaxSize TxParameters
#getTokenBundleMaxSize)
                , $sel:certificateDepositAmount:SelectionConstraints :: Coin
certificateDepositAmount =
                    ((Coin -> Const Coin Coin)
 -> ProtocolParameters -> Const Coin ProtocolParameters)
-> ProtocolParameters -> Coin
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "stakeKeyDeposit"
  ((Coin -> Const Coin Coin)
   -> ProtocolParameters -> Const Coin ProtocolParameters)
(Coin -> Const Coin Coin)
-> ProtocolParameters -> Const Coin ProtocolParameters
#stakeKeyDeposit ProtocolParameters
pp
                , $sel:computeMinimumAdaQuantity:SelectionConstraints :: Address -> TokenMap -> Coin
computeMinimumAdaQuantity =
                    (((Address -> TokenMap -> Coin)
  -> Const
       (Address -> TokenMap -> Coin) (Address -> TokenMap -> Coin))
 -> TxConstraints
 -> Const (Address -> TokenMap -> Coin) TxConstraints)
-> TxConstraints -> Address -> TokenMap -> Coin
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "txOutputMinimumAdaQuantity"
  (((Address -> TokenMap -> Coin)
    -> Const
         (Address -> TokenMap -> Coin) (Address -> TokenMap -> Coin))
   -> TxConstraints
   -> Const (Address -> TokenMap -> Coin) TxConstraints)
((Address -> TokenMap -> Coin)
 -> Const
      (Address -> TokenMap -> Coin) (Address -> TokenMap -> Coin))
-> TxConstraints
-> Const (Address -> TokenMap -> Coin) TxConstraints
#txOutputMinimumAdaQuantity
                        (TransactionLayer k SealedTx
-> AnyCardanoEra -> ProtocolParameters -> TxConstraints
forall (k :: Depth -> * -> *) tx.
TransactionLayer k tx
-> AnyCardanoEra -> ProtocolParameters -> TxConstraints
constraints TransactionLayer k SealedTx
tl AnyCardanoEra
era ProtocolParameters
pp)
                , $sel:isBelowMinimumAdaQuantity:SelectionConstraints :: Address -> TokenBundle -> Bool
isBelowMinimumAdaQuantity =
                    (((Address -> TokenBundle -> Bool)
  -> Const
       (Address -> TokenBundle -> Bool) (Address -> TokenBundle -> Bool))
 -> TxConstraints
 -> Const (Address -> TokenBundle -> Bool) TxConstraints)
-> TxConstraints -> Address -> TokenBundle -> Bool
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "txOutputBelowMinimumAdaQuantity"
  (((Address -> TokenBundle -> Bool)
    -> Const
         (Address -> TokenBundle -> Bool) (Address -> TokenBundle -> Bool))
   -> TxConstraints
   -> Const (Address -> TokenBundle -> Bool) TxConstraints)
((Address -> TokenBundle -> Bool)
 -> Const
      (Address -> TokenBundle -> Bool) (Address -> TokenBundle -> Bool))
-> TxConstraints
-> Const (Address -> TokenBundle -> Bool) TxConstraints
#txOutputBelowMinimumAdaQuantity
                        (TransactionLayer k SealedTx
-> AnyCardanoEra -> ProtocolParameters -> TxConstraints
forall (k :: Depth -> * -> *) tx.
TransactionLayer k tx
-> AnyCardanoEra -> ProtocolParameters -> TxConstraints
constraints TransactionLayer k SealedTx
tl AnyCardanoEra
era ProtocolParameters
pp)
                , $sel:computeMinimumCost:SelectionConstraints :: SelectionSkeleton -> Coin
computeMinimumCost = \SelectionSkeleton
skeleton -> [Coin] -> Coin
forall a. Monoid a => [a] -> a
mconcat
                    [ Coin
feePadding
                    , Lovelace -> Coin
fromCardanoLovelace Lovelace
fee0
                    , TransactionLayer k SealedTx
-> AnyCardanoEra
-> ProtocolParameters
-> TransactionCtx
-> SelectionSkeleton
-> Coin
forall (k :: Depth -> * -> *) tx.
TransactionLayer k tx
-> AnyCardanoEra
-> ProtocolParameters
-> TransactionCtx
-> SelectionSkeleton
-> Coin
calcMinimumCost TransactionLayer k SealedTx
tl AnyCardanoEra
era ProtocolParameters
pp
                        (TransactionCtx
defaultTransactionCtx
                            { $sel:txPlutusScriptExecutionCost:TransactionCtx :: Coin
txPlutusScriptExecutionCost =
                                Coin
txPlutusScriptExecutionCost })
                        SelectionSkeleton
skeleton
                    ] Coin -> Coin -> Coin
`Coin.difference` Coin
boringFee
                , $sel:computeSelectionLimit:SelectionConstraints :: [TxOut] -> SelectionLimit
computeSelectionLimit = \[TxOut]
_ -> SelectionLimit
forall a. SelectionLimitOf a
NoLimit
                , $sel:maximumCollateralInputCount:SelectionConstraints :: Int
maximumCollateralInputCount =
                    (Integral Word16, Integral Int, IsIntSubType Word16 Int ~ 'True) =>
Word16 -> Int
forall a b.
(Integral a, Integral b, IsIntSubType a b ~ 'True) =>
a -> b
intCast @Word16 @Int (Word16 -> Int) -> Word16 -> Int
forall a b. (a -> b) -> a -> b
$ ((Word16 -> Const Word16 Word16)
 -> ProtocolParameters -> Const Word16 ProtocolParameters)
-> ProtocolParameters -> Word16
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "maximumCollateralInputCount"
  ((Word16 -> Const Word16 Word16)
   -> ProtocolParameters -> Const Word16 ProtocolParameters)
(Word16 -> Const Word16 Word16)
-> ProtocolParameters -> Const Word16 ProtocolParameters
#maximumCollateralInputCount ProtocolParameters
pp
                , $sel:minimumCollateralPercentage:SelectionConstraints :: Natural
minimumCollateralPercentage =
                    ((Natural -> Const Natural Natural)
 -> ProtocolParameters -> Const Natural ProtocolParameters)
-> ProtocolParameters -> Natural
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "minimumCollateralPercentage"
  ((Natural -> Const Natural Natural)
   -> ProtocolParameters -> Const Natural ProtocolParameters)
(Natural -> Const Natural Natural)
-> ProtocolParameters -> Const Natural ProtocolParameters
#minimumCollateralPercentage ProtocolParameters
pp
                , $sel:maximumLengthChangeAddress:SelectionConstraints :: Address
maximumLengthChangeAddress =
                    Proxy k -> Address
forall k (key :: k).
BoundedAddressLength key =>
Proxy key -> Address
maxLengthAddressFor (Proxy k -> Address) -> Proxy k -> Address
forall a b. (a -> b) -> a -> b
$ Proxy k
forall k (t :: k). Proxy t
Proxy @k
                }

            selectionParams :: SelectionParams
selectionParams = SelectionParams :: TokenMap
-> TokenMap
-> Coin
-> Coin
-> [TxOut]
-> Coin
-> Natural
-> Natural
-> SelectionCollateralRequirement
-> Map WalletUTxO TokenBundle
-> UTxOSelection WalletUTxO
-> SelectionStrategy
-> SelectionParams
SelectionParams
                -- The following fields are essensially adjusting the coin
                -- selections notion of balance by @balance0 - sum inputs + sum
                -- outputs + fee0@ where @balance0@ is the balance of the
                -- partial tx.
                { $sel:assetsToMint:SelectionParams :: TokenMap
assetsToMint = TokenMap
positiveTokens TokenMap -> TokenMap -> TokenMap
forall a. Semigroup a => a -> a -> a
<> TokenMap
tokensInOutputs
                , $sel:assetsToBurn:SelectionParams :: TokenMap
assetsToBurn = TokenMap
negativeTokens TokenMap -> TokenMap -> TokenMap
forall a. Semigroup a => a -> a -> a
<> TokenMap
tokensInInputs
                , $sel:extraCoinIn:SelectionParams :: Coin
extraCoinIn =
                    Coin
positiveAda
                    Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
adaInOutputs
                    Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Lovelace -> Coin
fromCardanoLovelace Lovelace
fee0
                , $sel:extraCoinOut:SelectionParams :: Coin
extraCoinOut = Coin
negativeAda Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
adaInInputs

                -- We don't use the following 3 fields because certs and
                -- withdrawals are already included in the balance (passed in
                -- above).
                , $sel:rewardWithdrawal:SelectionParams :: Coin
rewardWithdrawal = Natural -> Coin
Coin Natural
0
                , $sel:certificateDepositsReturned:SelectionParams :: Natural
certificateDepositsReturned = Natural
0
                , $sel:certificateDepositsTaken:SelectionParams :: Natural
certificateDepositsTaken = Natural
0

                -- NOTE: It is important that coin selection has the correct
                -- notion of fees, because it will be used to tell how much
                -- collateral is needed.
                , $sel:collateralRequirement:SelectionParams :: SelectionCollateralRequirement
collateralRequirement = SelectionCollateralRequirement
colReq
                , $sel:outputsToCover:SelectionParams :: [TxOut]
outputsToCover = [TxOut]
outs
                , $sel:utxoAvailableForCollateral:SelectionParams :: Map WalletUTxO TokenBundle
utxoAvailableForCollateral =
                      UTxOSelection WalletUTxO -> Map WalletUTxO TokenBundle
forall (s :: * -> *) u.
(IsUTxOSelection s u, Ord u) =>
s u -> Map u TokenBundle
UTxOSelection.availableMap UTxOSelection WalletUTxO
utxoSelection
                , $sel:utxoAvailableForInputs:SelectionParams :: UTxOSelection WalletUTxO
utxoAvailableForInputs = UTxOSelection WalletUTxO
utxoSelection
                , $sel:selectionStrategy:SelectionParams :: SelectionStrategy
selectionStrategy = SelectionStrategy
selectionStrategy
                }
            in
                (Rand
   StdGen (Either (SelectionError WalletSelectionContext) Selection)
 -> StdGen
 -> Either (SelectionError WalletSelectionContext) Selection)
-> StdGen
-> Rand
     StdGen (Either (SelectionError WalletSelectionContext) Selection)
-> Either (SelectionError WalletSelectionContext) Selection
forall a b c. (a -> b -> c) -> b -> a -> c
flip Rand
  StdGen (Either (SelectionError WalletSelectionContext) Selection)
-> StdGen
-> Either (SelectionError WalletSelectionContext) Selection
forall g a. Rand g a -> g -> a
evalRand (StdGenSeed -> StdGen
stdGenFromSeed StdGenSeed
seed)
                    (Rand
   StdGen (Either (SelectionError WalletSelectionContext) Selection)
 -> Either (SelectionError WalletSelectionContext) Selection)
-> Rand
     StdGen (Either (SelectionError WalletSelectionContext) Selection)
-> Either (SelectionError WalletSelectionContext) Selection
forall a b. (a -> b) -> a -> b
$ ExceptT
  (SelectionError WalletSelectionContext)
  (RandT StdGen Identity)
  Selection
-> Rand
     StdGen (Either (SelectionError WalletSelectionContext) Selection)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
                    (ExceptT
   (SelectionError WalletSelectionContext)
   (RandT StdGen Identity)
   Selection
 -> Rand
      StdGen (Either (SelectionError WalletSelectionContext) Selection))
-> ExceptT
     (SelectionError WalletSelectionContext)
     (RandT StdGen Identity)
     Selection
-> Rand
     StdGen (Either (SelectionError WalletSelectionContext) Selection)
forall a b. (a -> b) -> a -> b
$ SelectionConstraints
-> SelectionParams
-> ExceptT
     (SelectionError WalletSelectionContext)
     (RandT StdGen Identity)
     Selection
forall (m :: * -> *).
(HasCallStack, MonadRandom m) =>
SelectionConstraints
-> SelectionParams
-> ExceptT (SelectionError WalletSelectionContext) m Selection
performSelection SelectionConstraints
selectionConstraints SelectionParams
selectionParams

-- | Augments the given outputs with new outputs. These new outputs correspond
-- to change outputs to which new addresses have been assigned. This updates
-- the wallet state as it needs to keep track of new pending change addresses.
assignChangeAddresses
    :: forall s. GenChange s
    => ArgGenChange s
    -> Selection
    -> s
    -> (SelectionOf TxOut, s)
assignChangeAddresses :: ArgGenChange s -> Selection -> s -> (SelectionOf TxOut, s)
assignChangeAddresses ArgGenChange s
argGenChange Selection
sel = State s (SelectionOf TxOut) -> s -> (SelectionOf TxOut, s)
forall s a. State s a -> s -> (a, s)
runState (State s (SelectionOf TxOut) -> s -> (SelectionOf TxOut, s))
-> State s (SelectionOf TxOut) -> s -> (SelectionOf TxOut, s)
forall a b. (a -> b) -> a -> b
$ do
    [TxOut]
changeOuts <- [TokenBundle]
-> (TokenBundle -> StateT s Identity TxOut)
-> StateT s Identity [TxOut]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ((([TokenBundle] -> Const [TokenBundle] [TokenBundle])
 -> Selection -> Const [TokenBundle] Selection)
-> Selection -> [TokenBundle]
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "change"
  (([TokenBundle] -> Const [TokenBundle] [TokenBundle])
   -> Selection -> Const [TokenBundle] Selection)
([TokenBundle] -> Const [TokenBundle] [TokenBundle])
-> Selection -> Const [TokenBundle] Selection
#change Selection
sel) ((TokenBundle -> StateT s Identity TxOut)
 -> StateT s Identity [TxOut])
-> (TokenBundle -> StateT s Identity TxOut)
-> StateT s Identity [TxOut]
forall a b. (a -> b) -> a -> b
$ \TokenBundle
bundle -> do
        Address
addr <- (s -> (Address, s)) -> StateT s Identity Address
forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state (ArgGenChange s -> s -> (Address, s)
forall s. GenChange s => ArgGenChange s -> s -> (Address, s)
genChange ArgGenChange s
argGenChange)
        TxOut -> StateT s Identity TxOut
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxOut -> StateT s Identity TxOut)
-> TxOut -> StateT s Identity TxOut
forall a b. (a -> b) -> a -> b
$ Address -> TokenBundle -> TxOut
TxOut Address
addr TokenBundle
bundle
    SelectionOf TxOut -> State s (SelectionOf TxOut)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SelectionOf TxOut -> State s (SelectionOf TxOut))
-> SelectionOf TxOut -> State s (SelectionOf TxOut)
forall a b. (a -> b) -> a -> b
$ Selection
sel { $sel:change:Selection :: [TxOut]
change = [TxOut]
changeOuts }

assignChangeAddressesAndUpdateDb
    :: forall ctx s k.
        ( GenChange s
        , HasDBLayer IO s k ctx
        , AddressBookIso s
        )
    => ctx
    -> WalletId
    -> ArgGenChange s
    -> Selection
    -> ExceptT ErrSignPayment IO (SelectionOf TxOut)
assignChangeAddressesAndUpdateDb :: ctx
-> WalletId
-> ArgGenChange s
-> Selection
-> ExceptT ErrSignPayment IO (SelectionOf TxOut)
assignChangeAddressesAndUpdateDb ctx
ctx WalletId
wid ArgGenChange s
generateChange Selection
selection =
    DBLayer IO s k
db DBLayer IO s k
-> (DBLayer IO s k
    -> ExceptT ErrSignPayment IO (SelectionOf TxOut))
-> ExceptT ErrSignPayment IO (SelectionOf TxOut)
forall a b. a -> (a -> b) -> b
& \DBLayer{stm [WalletId]
DBVar stm (DeltaMap WalletId (DeltaWalletState s))
WalletId -> stm [LocalTxSubmissionStatus SealedTx]
WalletId -> stm [ChainPoint]
WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
WalletId -> stm (Maybe GenesisParameters)
WalletId -> stm (Maybe WalletMetadata)
WalletId -> stm (Maybe (Wallet s))
WalletId -> stm Coin
WalletId -> ExceptT ErrNoSuchWallet stm Bool
WalletId -> ExceptT ErrNoSuchWallet stm ()
WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
forall a. stm a -> IO a
atomically :: forall a. stm a -> IO a
prune :: WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
rollbackTo :: WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
readGenesisParameters :: WalletId -> stm (Maybe GenesisParameters)
readPrivateKey :: WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
putPrivateKey :: WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
removePendingOrExpiredTx :: WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
updatePendingTxForExpiry :: WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
readLocalTxSubmissionPending :: WalletId -> stm [LocalTxSubmissionStatus SealedTx]
putLocalTxSubmission :: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
getTx :: WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
readTxHistory :: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
putTxHistory :: WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
readDelegationRewardBalance :: WalletId -> stm Coin
putDelegationRewardBalance :: WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
putDelegationCertificate :: WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
isStakeKeyRegistered :: WalletId -> ExceptT ErrNoSuchWallet stm Bool
readWalletMeta :: WalletId -> stm (Maybe WalletMetadata)
putWalletMeta :: WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
listCheckpoints :: WalletId -> stm [ChainPoint]
readCheckpoint :: WalletId -> stm (Maybe (Wallet s))
putCheckpoint :: WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
walletsDB :: DBVar stm (DeltaMap WalletId (DeltaWalletState s))
listWallets :: stm [WalletId]
removeWallet :: WalletId -> ExceptT ErrNoSuchWallet stm ()
initializeWallet :: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
atomically :: ()
prune :: ()
rollbackTo :: ()
readGenesisParameters :: ()
readPrivateKey :: ()
putPrivateKey :: ()
removePendingOrExpiredTx :: ()
updatePendingTxForExpiry :: ()
readLocalTxSubmissionPending :: ()
putLocalTxSubmission :: ()
getTx :: ()
readTxHistory :: ()
putTxHistory :: ()
readDelegationRewardBalance :: ()
putDelegationRewardBalance :: ()
putDelegationCertificate :: ()
isStakeKeyRegistered :: ()
readWalletMeta :: ()
putWalletMeta :: ()
listCheckpoints :: ()
readCheckpoint :: ()
putCheckpoint :: ()
walletsDB :: ()
listWallets :: ()
removeWallet :: ()
initializeWallet :: ()
..} -> IO (Either ErrSignPayment (SelectionOf TxOut))
-> ExceptT ErrSignPayment IO (SelectionOf TxOut)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ErrSignPayment (SelectionOf TxOut))
 -> ExceptT ErrSignPayment IO (SelectionOf TxOut))
-> IO (Either ErrSignPayment (SelectionOf TxOut))
-> ExceptT ErrSignPayment IO (SelectionOf TxOut)
forall a b. (a -> b) -> a -> b
$ stm (Either ErrSignPayment (SelectionOf TxOut))
-> IO (Either ErrSignPayment (SelectionOf TxOut))
forall a. stm a -> IO a
atomically (stm (Either ErrSignPayment (SelectionOf TxOut))
 -> IO (Either ErrSignPayment (SelectionOf TxOut)))
-> stm (Either ErrSignPayment (SelectionOf TxOut))
-> IO (Either ErrSignPayment (SelectionOf TxOut))
forall a b. (a -> b) -> a -> b
$ DBVar stm (DeltaMap WalletId (DeltaWalletState s))
-> (Map WalletId (WalletState s)
    -> (Maybe (DeltaMap WalletId (DeltaWalletState s)),
        Either ErrSignPayment (SelectionOf TxOut)))
-> stm (Either ErrSignPayment (SelectionOf TxOut))
forall da (m :: * -> *) a b.
(Delta da, Monad m, a ~ Base da) =>
DBVar m da -> (a -> (Maybe da, b)) -> m b
modifyDBMaybe DBVar stm (DeltaMap WalletId (DeltaWalletState s))
walletsDB ((Map WalletId (WalletState s)
  -> (Maybe (DeltaMap WalletId (DeltaWalletState s)),
      Either ErrSignPayment (SelectionOf TxOut)))
 -> stm (Either ErrSignPayment (SelectionOf TxOut)))
-> (Map WalletId (WalletState s)
    -> (Maybe (DeltaMap WalletId (DeltaWalletState s)),
        Either ErrSignPayment (SelectionOf TxOut)))
-> stm (Either ErrSignPayment (SelectionOf TxOut))
forall a b. (a -> b) -> a -> b
$
        WalletId
-> (ErrNoSuchWallet -> ErrSignPayment)
-> (WalletState s
    -> Either ErrSignPayment (DeltaWalletState s, SelectionOf TxOut))
-> Map WalletId (WalletState s)
-> (Maybe (DeltaMap WalletId (DeltaWalletState s)),
    Either ErrSignPayment (SelectionOf TxOut))
forall e w dw b.
WalletId
-> (ErrNoSuchWallet -> e)
-> (w -> Either e (dw, b))
-> Map WalletId w
-> (Maybe (DeltaMap WalletId dw), Either e b)
adjustNoSuchWallet WalletId
wid ErrNoSuchWallet -> ErrSignPayment
ErrSignPaymentNoSuchWallet
            WalletState s
-> Either ErrSignPayment (DeltaWalletState s, SelectionOf TxOut)
assignChangeAddressesAndUpdateDb'
  where
    db :: DBLayer IO s k
db = ctx
ctx ctx
-> ((DBLayer IO s k -> Const (DBLayer IO s k) (DBLayer IO s k))
    -> ctx -> Const (DBLayer IO s k) ctx)
-> DBLayer IO s k
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx. HasDBLayer IO s k ctx => Lens' ctx (DBLayer IO s k)
forall (m :: * -> *) s (k :: Depth -> * -> *) ctx.
HasDBLayer m s k ctx =>
Lens' ctx (DBLayer m s k)
dbLayer @IO @s @k
    assignChangeAddressesAndUpdateDb' :: WalletState s
-> Either ErrSignPayment (DeltaWalletState s, SelectionOf TxOut)
assignChangeAddressesAndUpdateDb' WalletState s
wallet = (DeltaWalletState s, SelectionOf TxOut)
-> Either ErrSignPayment (DeltaWalletState s, SelectionOf TxOut)
forall a b. b -> Either a b
Right
        -- Newly generated change addresses only change the Prologue
        ([Prologue s -> DeltaWalletState1 s
forall s. Prologue s -> DeltaWalletState1 s
ReplacePrologue (Prologue s -> DeltaWalletState1 s)
-> Prologue s -> DeltaWalletState1 s
forall a b. (a -> b) -> a -> b
$ s -> Prologue s
forall s. AddressBookIso s => s -> Prologue s
getPrologue s
stateUpdated], SelectionOf TxOut
selectionUpdated)
      where
        s :: s
s = Wallet s -> s
forall s. Wallet s -> s
getState (Wallet s -> s) -> Wallet s -> s
forall a b. (a -> b) -> a -> b
$ WalletState s -> Wallet s
forall s. AddressBookIso s => WalletState s -> Wallet s
getLatest WalletState s
wallet
        (SelectionOf TxOut
selectionUpdated, s
stateUpdated) =
            ArgGenChange s -> Selection -> s -> (SelectionOf TxOut, s)
forall s.
GenChange s =>
ArgGenChange s -> Selection -> s -> (SelectionOf TxOut, s)
assignChangeAddresses ArgGenChange s
generateChange Selection
selection s
s

assignChangeAddressesWithoutDbUpdate
    :: forall ctx s k.
        ( GenChange s
        , HasDBLayer IO s k ctx
        )
    => ctx
    -> WalletId
    -> ArgGenChange s
    -> Selection
    -> ExceptT ErrConstructTx IO (SelectionOf TxOut)
assignChangeAddressesWithoutDbUpdate :: ctx
-> WalletId
-> ArgGenChange s
-> Selection
-> ExceptT ErrConstructTx IO (SelectionOf TxOut)
assignChangeAddressesWithoutDbUpdate ctx
ctx WalletId
wid ArgGenChange s
generateChange Selection
selection =
    DBLayer IO s k
db DBLayer IO s k
-> (DBLayer IO s k
    -> ExceptT ErrConstructTx IO (SelectionOf TxOut))
-> ExceptT ErrConstructTx IO (SelectionOf TxOut)
forall a b. a -> (a -> b) -> b
& \DBLayer{stm [WalletId]
DBVar stm (DeltaMap WalletId (DeltaWalletState s))
WalletId -> stm [LocalTxSubmissionStatus SealedTx]
WalletId -> stm [ChainPoint]
WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
WalletId -> stm (Maybe GenesisParameters)
WalletId -> stm (Maybe WalletMetadata)
WalletId -> stm (Maybe (Wallet s))
WalletId -> stm Coin
WalletId -> ExceptT ErrNoSuchWallet stm Bool
WalletId -> ExceptT ErrNoSuchWallet stm ()
WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
forall a. stm a -> IO a
atomically :: forall a. stm a -> IO a
prune :: WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
rollbackTo :: WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
readGenesisParameters :: WalletId -> stm (Maybe GenesisParameters)
readPrivateKey :: WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
putPrivateKey :: WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
removePendingOrExpiredTx :: WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
updatePendingTxForExpiry :: WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
readLocalTxSubmissionPending :: WalletId -> stm [LocalTxSubmissionStatus SealedTx]
putLocalTxSubmission :: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
getTx :: WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
readTxHistory :: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
putTxHistory :: WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
readDelegationRewardBalance :: WalletId -> stm Coin
putDelegationRewardBalance :: WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
putDelegationCertificate :: WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
isStakeKeyRegistered :: WalletId -> ExceptT ErrNoSuchWallet stm Bool
readWalletMeta :: WalletId -> stm (Maybe WalletMetadata)
putWalletMeta :: WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
listCheckpoints :: WalletId -> stm [ChainPoint]
readCheckpoint :: WalletId -> stm (Maybe (Wallet s))
putCheckpoint :: WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
walletsDB :: DBVar stm (DeltaMap WalletId (DeltaWalletState s))
listWallets :: stm [WalletId]
removeWallet :: WalletId -> ExceptT ErrNoSuchWallet stm ()
initializeWallet :: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
atomically :: ()
prune :: ()
rollbackTo :: ()
readGenesisParameters :: ()
readPrivateKey :: ()
putPrivateKey :: ()
removePendingOrExpiredTx :: ()
updatePendingTxForExpiry :: ()
readLocalTxSubmissionPending :: ()
putLocalTxSubmission :: ()
getTx :: ()
readTxHistory :: ()
putTxHistory :: ()
readDelegationRewardBalance :: ()
putDelegationRewardBalance :: ()
putDelegationCertificate :: ()
isStakeKeyRegistered :: ()
readWalletMeta :: ()
putWalletMeta :: ()
listCheckpoints :: ()
readCheckpoint :: ()
putCheckpoint :: ()
walletsDB :: ()
listWallets :: ()
removeWallet :: ()
initializeWallet :: ()
..} -> (stm (Either ErrConstructTx (SelectionOf TxOut))
 -> IO (Either ErrConstructTx (SelectionOf TxOut)))
-> ExceptT ErrConstructTx stm (SelectionOf TxOut)
-> ExceptT ErrConstructTx IO (SelectionOf TxOut)
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT stm (Either ErrConstructTx (SelectionOf TxOut))
-> IO (Either ErrConstructTx (SelectionOf TxOut))
forall a. stm a -> IO a
atomically (ExceptT ErrConstructTx stm (SelectionOf TxOut)
 -> ExceptT ErrConstructTx IO (SelectionOf TxOut))
-> ExceptT ErrConstructTx stm (SelectionOf TxOut)
-> ExceptT ErrConstructTx IO (SelectionOf TxOut)
forall a b. (a -> b) -> a -> b
$ do
        Wallet s
cp <- (ErrNoSuchWallet -> ErrConstructTx)
-> ExceptT ErrNoSuchWallet stm (Wallet s)
-> ExceptT ErrConstructTx stm (Wallet s)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ErrNoSuchWallet -> ErrConstructTx
ErrConstructTxNoSuchWallet (ExceptT ErrNoSuchWallet stm (Wallet s)
 -> ExceptT ErrConstructTx stm (Wallet s))
-> ExceptT ErrNoSuchWallet stm (Wallet s)
-> ExceptT ErrConstructTx stm (Wallet s)
forall a b. (a -> b) -> a -> b
$
            WalletId
-> stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s)
forall (m :: * -> *) a.
Monad m =>
WalletId -> m (Maybe a) -> ExceptT ErrNoSuchWallet m a
withNoSuchWallet WalletId
wid (stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s))
-> stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s)
forall a b. (a -> b) -> a -> b
$ WalletId -> stm (Maybe (Wallet s))
readCheckpoint WalletId
wid
        let (SelectionOf TxOut
selectionUpdated, s
_) =
                ArgGenChange s -> Selection -> s -> (SelectionOf TxOut, s)
forall s.
GenChange s =>
ArgGenChange s -> Selection -> s -> (SelectionOf TxOut, s)
assignChangeAddresses ArgGenChange s
generateChange Selection
selection (Wallet s -> s
forall s. Wallet s -> s
getState Wallet s
cp)
        SelectionOf TxOut -> ExceptT ErrConstructTx stm (SelectionOf TxOut)
forall (f :: * -> *) a. Applicative f => a -> f a
pure SelectionOf TxOut
selectionUpdated
  where
    db :: DBLayer IO s k
db = ctx
ctx ctx
-> ((DBLayer IO s k -> Const (DBLayer IO s k) (DBLayer IO s k))
    -> ctx -> Const (DBLayer IO s k) ctx)
-> DBLayer IO s k
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx. HasDBLayer IO s k ctx => Lens' ctx (DBLayer IO s k)
forall (m :: * -> *) s (k :: Depth -> * -> *) ctx.
HasDBLayer m s k ctx =>
Lens' ctx (DBLayer m s k)
dbLayer @IO @s @k

selectionToUnsignedTx
    :: forall s input output change withdrawal.
        ( IsOurs s Address
        , input ~ (TxIn, TxOut, NonEmpty DerivationIndex)
        , output ~ TxOut
        , change ~ TxChange (NonEmpty DerivationIndex)
        , withdrawal ~ (RewardAccount, Coin, NonEmpty DerivationIndex)
        )
    => Withdrawal
    -> SelectionOf TxOut
    -> s
    -> (UnsignedTx input output change withdrawal)
selectionToUnsignedTx :: Withdrawal
-> SelectionOf TxOut
-> s
-> UnsignedTx input output change withdrawal
selectionToUnsignedTx Withdrawal
wdrl SelectionOf TxOut
sel s
s =
    UnsignedTx :: forall input output change withdrawal.
[input]
-> [input]
-> [output]
-> [change]
-> [withdrawal]
-> UnsignedTx input output change withdrawal
UnsignedTx
        { $sel:unsignedInputs:UnsignedTx :: [input]
unsignedInputs =
            [(TxIn, TxOut)] -> [input]
fullyQualifiedInputs ([(TxIn, TxOut)] -> [input]) -> [(TxIn, TxOut)] -> [input]
forall a b. (a -> b) -> a -> b
$ NonEmpty (TxIn, TxOut) -> [(TxIn, TxOut)]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty (TxIn, TxOut) -> [(TxIn, TxOut)])
-> NonEmpty (TxIn, TxOut) -> [(TxIn, TxOut)]
forall a b. (a -> b) -> a -> b
$ ((NonEmpty (TxIn, TxOut)
  -> Const (NonEmpty (TxIn, TxOut)) (NonEmpty (TxIn, TxOut)))
 -> SelectionOf TxOut
 -> Const (NonEmpty (TxIn, TxOut)) (SelectionOf TxOut))
-> SelectionOf TxOut -> NonEmpty (TxIn, TxOut)
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "inputs"
  ((NonEmpty (TxIn, TxOut)
    -> Const (NonEmpty (TxIn, TxOut)) (NonEmpty (TxIn, TxOut)))
   -> SelectionOf TxOut
   -> Const (NonEmpty (TxIn, TxOut)) (SelectionOf TxOut))
(NonEmpty (TxIn, TxOut)
 -> Const (NonEmpty (TxIn, TxOut)) (NonEmpty (TxIn, TxOut)))
-> SelectionOf TxOut
-> Const (NonEmpty (TxIn, TxOut)) (SelectionOf TxOut)
#inputs SelectionOf TxOut
sel
        , $sel:unsignedOutputs:UnsignedTx :: [output]
unsignedOutputs =
            (([output] -> Const [output] [output])
 -> SelectionOf TxOut -> Const [output] (SelectionOf TxOut))
-> SelectionOf TxOut -> [output]
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "outputs"
  (([output] -> Const [output] [output])
   -> SelectionOf TxOut -> Const [output] (SelectionOf TxOut))
([output] -> Const [output] [output])
-> SelectionOf TxOut -> Const [output] (SelectionOf TxOut)
#outputs SelectionOf TxOut
sel
        , $sel:unsignedChange:UnsignedTx :: [change]
unsignedChange =
            [TxOut] -> [change]
fullyQualifiedChange ([TxOut] -> [change]) -> [TxOut] -> [change]
forall a b. (a -> b) -> a -> b
$ (([TxOut] -> Const [TxOut] [TxOut])
 -> SelectionOf TxOut -> Const [TxOut] (SelectionOf TxOut))
-> SelectionOf TxOut -> [TxOut]
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "change"
  (([TxOut] -> Const [TxOut] [TxOut])
   -> SelectionOf TxOut -> Const [TxOut] (SelectionOf TxOut))
([TxOut] -> Const [TxOut] [TxOut])
-> SelectionOf TxOut -> Const [TxOut] (SelectionOf TxOut)
#change SelectionOf TxOut
sel
        , $sel:unsignedCollateral:UnsignedTx :: [input]
unsignedCollateral =
            [(TxIn, TxOut)] -> [input]
fullyQualifiedInputs ([(TxIn, TxOut)] -> [input]) -> [(TxIn, TxOut)] -> [input]
forall a b. (a -> b) -> a -> b
$ (([(TxIn, TxOut)] -> Const [(TxIn, TxOut)] [(TxIn, TxOut)])
 -> SelectionOf TxOut -> Const [(TxIn, TxOut)] (SelectionOf TxOut))
-> SelectionOf TxOut -> [(TxIn, TxOut)]
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "collateral"
  (([(TxIn, TxOut)] -> Const [(TxIn, TxOut)] [(TxIn, TxOut)])
   -> SelectionOf TxOut -> Const [(TxIn, TxOut)] (SelectionOf TxOut))
([(TxIn, TxOut)] -> Const [(TxIn, TxOut)] [(TxIn, TxOut)])
-> SelectionOf TxOut -> Const [(TxIn, TxOut)] (SelectionOf TxOut)
#collateral SelectionOf TxOut
sel
        , $sel:unsignedWithdrawals:UnsignedTx :: [withdrawal]
unsignedWithdrawals =
            Withdrawal -> [withdrawal]
fullyQualifiedWithdrawal Withdrawal
wdrl
        }
  where
    -- NOTE: External addresses, not known to the wallet, will be filtered out.
    qualifyAddresses
        :: (a -> Address)
        -> [a]
        -> [(a, NonEmpty DerivationIndex)]
    qualifyAddresses :: (a -> Address) -> [a] -> [(a, NonEmpty DerivationIndex)]
qualifyAddresses a -> Address
getAddress [a]
hasAddresses =
        (a -> Maybe (a, NonEmpty DerivationIndex))
-> [a] -> [(a, NonEmpty DerivationIndex)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe a -> Maybe (a, NonEmpty DerivationIndex)
withDerivationPath [a]
hasAddresses
      where
        withDerivationPath :: a -> Maybe (a, NonEmpty DerivationIndex)
withDerivationPath a
hasAddress =
            (a
hasAddress,) (NonEmpty DerivationIndex -> (a, NonEmpty DerivationIndex))
-> Maybe (NonEmpty DerivationIndex)
-> Maybe (a, NonEmpty DerivationIndex)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe (NonEmpty DerivationIndex), s)
-> Maybe (NonEmpty DerivationIndex)
forall a b. (a, b) -> a
fst (Address -> s -> (Maybe (NonEmpty DerivationIndex), s)
forall s entity.
IsOurs s entity =>
entity -> s -> (Maybe (NonEmpty DerivationIndex), s)
isOurs (a -> Address
getAddress a
hasAddress) s
s)

    fullyQualifiedInputs :: [(TxIn, TxOut)] -> [input]
    fullyQualifiedInputs :: [(TxIn, TxOut)] -> [input]
fullyQualifiedInputs =
        (((TxIn, TxOut), NonEmpty DerivationIndex)
 -> (TxIn, TxOut, NonEmpty DerivationIndex))
-> [((TxIn, TxOut), NonEmpty DerivationIndex)]
-> [(TxIn, TxOut, NonEmpty DerivationIndex)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((TxIn, TxOut), NonEmpty DerivationIndex)
-> (TxIn, TxOut, NonEmpty DerivationIndex)
forall a b c. ((a, b), c) -> (a, b, c)
mkInput ([((TxIn, TxOut), NonEmpty DerivationIndex)]
 -> [(TxIn, TxOut, NonEmpty DerivationIndex)])
-> ([(TxIn, TxOut)] -> [((TxIn, TxOut), NonEmpty DerivationIndex)])
-> [(TxIn, TxOut)]
-> [(TxIn, TxOut, NonEmpty DerivationIndex)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TxIn, TxOut) -> Address)
-> [(TxIn, TxOut)] -> [((TxIn, TxOut), NonEmpty DerivationIndex)]
forall a. (a -> Address) -> [a] -> [(a, NonEmpty DerivationIndex)]
qualifyAddresses (((Address -> Const Address Address)
 -> TxOut -> Const Address TxOut)
-> TxOut -> Address
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "address"
  ((Address -> Const Address Address)
   -> TxOut -> Const Address TxOut)
(Address -> Const Address Address) -> TxOut -> Const Address TxOut
#address (TxOut -> Address)
-> ((TxIn, TxOut) -> TxOut) -> (TxIn, TxOut) -> Address
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn, TxOut) -> TxOut
forall a b. (a, b) -> b
snd)
      where
        mkInput :: ((a, b), c) -> (a, b, c)
mkInput ((a
txin, b
txout), c
path) = (a
txin, b
txout, c
path)

    fullyQualifiedChange :: [TxOut] -> [change]
    fullyQualifiedChange :: [TxOut] -> [change]
fullyQualifiedChange =
        ((TxOut, NonEmpty DerivationIndex)
 -> TxChange (NonEmpty DerivationIndex))
-> [(TxOut, NonEmpty DerivationIndex)]
-> [TxChange (NonEmpty DerivationIndex)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TxOut, NonEmpty DerivationIndex)
-> TxChange (NonEmpty DerivationIndex)
forall derivationPath.
(TxOut, derivationPath) -> TxChange derivationPath
mkChange ([(TxOut, NonEmpty DerivationIndex)]
 -> [TxChange (NonEmpty DerivationIndex)])
-> ([TxOut] -> [(TxOut, NonEmpty DerivationIndex)])
-> [TxOut]
-> [TxChange (NonEmpty DerivationIndex)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxOut -> Address)
-> [TxOut] -> [(TxOut, NonEmpty DerivationIndex)]
forall a. (a -> Address) -> [a] -> [(a, NonEmpty DerivationIndex)]
qualifyAddresses (((Address -> Const Address Address)
 -> TxOut -> Const Address TxOut)
-> TxOut -> Address
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "address"
  ((Address -> Const Address Address)
   -> TxOut -> Const Address TxOut)
(Address -> Const Address Address) -> TxOut -> Const Address TxOut
#address)
      where
        mkChange :: (TxOut, derivationPath) -> TxChange derivationPath
mkChange (TxOut Address
address TokenBundle
bundle, derivationPath
derivationPath) = TxChange :: forall derivationPath.
Address
-> Coin -> TokenMap -> derivationPath -> TxChange derivationPath
TxChange {derivationPath
Address
TokenMap
Coin
$sel:derivationPath:TxChange :: derivationPath
$sel:assets:TxChange :: TokenMap
$sel:amount:TxChange :: Coin
$sel:address:TxChange :: Address
assets :: TokenMap
amount :: Coin
derivationPath :: derivationPath
address :: Address
..}
          where
            amount :: Coin
amount = ((Coin -> Const Coin Coin)
 -> TokenBundle -> Const Coin TokenBundle)
-> TokenBundle -> Coin
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "coin"
  ((Coin -> Const Coin Coin)
   -> TokenBundle -> Const Coin TokenBundle)
(Coin -> Const Coin Coin) -> TokenBundle -> Const Coin TokenBundle
#coin   TokenBundle
bundle
            assets :: TokenMap
assets = ((TokenMap -> Const TokenMap TokenMap)
 -> TokenBundle -> Const TokenMap TokenBundle)
-> TokenBundle -> TokenMap
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "tokens"
  ((TokenMap -> Const TokenMap TokenMap)
   -> TokenBundle -> Const TokenMap TokenBundle)
(TokenMap -> Const TokenMap TokenMap)
-> TokenBundle -> Const TokenMap TokenBundle
#tokens TokenBundle
bundle

    fullyQualifiedWithdrawal :: Withdrawal -> [withdrawal]
    fullyQualifiedWithdrawal :: Withdrawal -> [withdrawal]
fullyQualifiedWithdrawal = \case
        Withdrawal
NoWithdrawal ->
            []
        WithdrawalSelf RewardAccount
acct NonEmpty DerivationIndex
path Coin
c ->
            [(RewardAccount
acct, Coin
c, NonEmpty DerivationIndex
path)]
        WithdrawalExternal RewardAccount
acct NonEmpty DerivationIndex
path Coin
c ->
            [(RewardAccount
acct, Coin
c, NonEmpty DerivationIndex
path)]

-- | Read a wallet checkpoint and index its UTxO, for 'selectAssets' and
-- 'selectAssetsNoOutputs'.
readWalletUTxOIndex
    :: forall ctx s k. HasDBLayer IO s k ctx
    => ctx
    -> WalletId
    -> ExceptT ErrNoSuchWallet IO (UTxOIndex WalletUTxO, Wallet s, Set Tx)
readWalletUTxOIndex :: ctx
-> WalletId
-> ExceptT
     ErrNoSuchWallet IO (UTxOIndex WalletUTxO, Wallet s, Set Tx)
readWalletUTxOIndex ctx
ctx WalletId
wid = do
    (Wallet s
cp, WalletMetadata
_, Set Tx
pending) <- ctx
-> WalletId
-> ExceptT ErrNoSuchWallet IO (Wallet s, WalletMetadata, Set Tx)
forall ctx s (k :: Depth -> * -> *).
HasDBLayer IO s k ctx =>
ctx
-> WalletId
-> ExceptT ErrNoSuchWallet IO (Wallet s, WalletMetadata, Set Tx)
readWallet @ctx @s @k ctx
ctx WalletId
wid
    let utxo :: UTxOIndex WalletUTxO
utxo = Map WalletUTxO TokenBundle -> UTxOIndex WalletUTxO
forall u. Ord u => Map u TokenBundle -> UTxOIndex u
UTxOIndex.fromMap (Map WalletUTxO TokenBundle -> UTxOIndex WalletUTxO)
-> Map WalletUTxO TokenBundle -> UTxOIndex WalletUTxO
forall a b. (a -> b) -> a -> b
$
            UTxO -> Map WalletUTxO TokenBundle
CS.toInternalUTxOMap (UTxO -> Map WalletUTxO TokenBundle)
-> UTxO -> Map WalletUTxO TokenBundle
forall a b. (a -> b) -> a -> b
$ Set Tx -> Wallet s -> UTxO
forall s. Set Tx -> Wallet s -> UTxO
availableUTxO @s Set Tx
pending Wallet s
cp
    (UTxOIndex WalletUTxO, Wallet s, Set Tx)
-> ExceptT
     ErrNoSuchWallet IO (UTxOIndex WalletUTxO, Wallet s, Set Tx)
forall (m :: * -> *) a. Monad m => a -> m a
return (UTxOIndex WalletUTxO
utxo, Wallet s
cp, Set Tx
pending)

-- | Calculate the minimum coin values required for a bunch of specified
-- outputs.
calcMinimumCoinValues
    :: forall ctx k f.
        ( HasTransactionLayer k ctx
        , HasNetworkLayer IO ctx
        , Applicative f
        )
    => ctx
    -> Cardano.AnyCardanoEra
    -> f TxOut
    -> IO (f Coin)
calcMinimumCoinValues :: ctx -> AnyCardanoEra -> f TxOut -> IO (f Coin)
calcMinimumCoinValues ctx
ctx AnyCardanoEra
era f TxOut
outs = do
    ProtocolParameters
pp <- NetworkLayer IO Block -> IO ProtocolParameters
forall (m :: * -> *) block.
NetworkLayer m block -> m ProtocolParameters
currentProtocolParameters NetworkLayer IO Block
nl
    f Coin -> IO (f Coin)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (f Coin -> IO (f Coin)) -> f Coin -> IO (f Coin)
forall a b. (a -> b) -> a -> b
$ (Address -> TokenMap -> Coin) -> (Address, TokenMap) -> Coin
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((((Address -> TokenMap -> Coin)
  -> Const
       (Address -> TokenMap -> Coin) (Address -> TokenMap -> Coin))
 -> TxConstraints
 -> Const (Address -> TokenMap -> Coin) TxConstraints)
-> TxConstraints -> Address -> TokenMap -> Coin
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "txOutputMinimumAdaQuantity"
  (((Address -> TokenMap -> Coin)
    -> Const
         (Address -> TokenMap -> Coin) (Address -> TokenMap -> Coin))
   -> TxConstraints
   -> Const (Address -> TokenMap -> Coin) TxConstraints)
((Address -> TokenMap -> Coin)
 -> Const
      (Address -> TokenMap -> Coin) (Address -> TokenMap -> Coin))
-> TxConstraints
-> Const (Address -> TokenMap -> Coin) TxConstraints
#txOutputMinimumAdaQuantity (TransactionLayer k SealedTx
-> AnyCardanoEra -> ProtocolParameters -> TxConstraints
forall (k :: Depth -> * -> *) tx.
TransactionLayer k tx
-> AnyCardanoEra -> ProtocolParameters -> TxConstraints
constraints TransactionLayer k SealedTx
tl AnyCardanoEra
era ProtocolParameters
pp))
        ((Address, TokenMap) -> Coin)
-> (TxOut -> (Address, TokenMap)) -> TxOut -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\TxOut
o -> (((Address -> Const Address Address)
 -> TxOut -> Const Address TxOut)
-> TxOut -> Address
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "address"
  ((Address -> Const Address Address)
   -> TxOut -> Const Address TxOut)
(Address -> Const Address Address) -> TxOut -> Const Address TxOut
#address TxOut
o, ((TokenMap -> Const TokenMap TokenMap)
 -> TxOut -> Const TokenMap TxOut)
-> TxOut -> TokenMap
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view (IsLabel
  "tokens"
  ((TokenBundle -> Const TokenMap TokenBundle)
   -> TxOut -> Const TokenMap TxOut)
(TokenBundle -> Const TokenMap TokenBundle)
-> TxOut -> Const TokenMap TxOut
#tokens ((TokenBundle -> Const TokenMap TokenBundle)
 -> TxOut -> Const TokenMap TxOut)
-> ((TokenMap -> Const TokenMap TokenMap)
    -> TokenBundle -> Const TokenMap TokenBundle)
-> (TokenMap -> Const TokenMap TokenMap)
-> TxOut
-> Const TokenMap TxOut
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IsLabel
  "tokens"
  ((TokenMap -> Const TokenMap TokenMap)
   -> TokenBundle -> Const TokenMap TokenBundle)
(TokenMap -> Const TokenMap TokenMap)
-> TokenBundle -> Const TokenMap TokenBundle
#tokens) TxOut
o)) (TxOut -> Coin) -> f TxOut -> f Coin
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f TxOut
outs
  where
    nl :: NetworkLayer IO Block
nl = ctx
ctx ctx
-> ((NetworkLayer IO Block
     -> Const (NetworkLayer IO Block) (NetworkLayer IO Block))
    -> ctx -> Const (NetworkLayer IO Block) ctx)
-> NetworkLayer IO Block
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. (NetworkLayer IO Block
 -> Const (NetworkLayer IO Block) (NetworkLayer IO Block))
-> ctx -> Const (NetworkLayer IO Block) ctx
forall (m :: * -> *) ctx.
HasNetworkLayer m ctx =>
Lens' ctx (NetworkLayer m Block)
networkLayer
    tl :: TransactionLayer k SealedTx
tl = ctx
ctx ctx
-> ((TransactionLayer k SealedTx
     -> Const
          (TransactionLayer k SealedTx) (TransactionLayer k SealedTx))
    -> ctx -> Const (TransactionLayer k SealedTx) ctx)
-> TransactionLayer k SealedTx
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx.
HasTransactionLayer k ctx =>
Lens' ctx (TransactionLayer k SealedTx)
forall (k :: Depth -> * -> *) ctx.
HasTransactionLayer k ctx =>
Lens' ctx (TransactionLayer k SealedTx)
transactionLayer @k

-- | Parameters for the 'selectAssets' function.
--
data SelectAssetsParams s result = SelectAssetsParams
    { SelectAssetsParams s result -> [TxOut]
outputs :: [TxOut]
    , SelectAssetsParams s result -> Set Tx
pendingTxs :: Set Tx
    , SelectAssetsParams s result -> Maybe StdGenSeed
randomSeed :: Maybe StdGenSeed
    , SelectAssetsParams s result -> TransactionCtx
txContext :: TransactionCtx
    , SelectAssetsParams s result -> Map WalletUTxO TokenBundle
utxoAvailableForCollateral :: Map WalletUTxO TokenBundle
    , SelectAssetsParams s result -> UTxOSelection WalletUTxO
utxoAvailableForInputs :: UTxOSelection WalletUTxO
    , SelectAssetsParams s result -> Wallet s
wallet :: Wallet s
    , SelectAssetsParams s result -> SelectionStrategy
selectionStrategy :: SelectionStrategy
        -- ^ Specifies which selection strategy to use. See 'SelectionStrategy'.
    }
    deriving (forall x.
 SelectAssetsParams s result -> Rep (SelectAssetsParams s result) x)
-> (forall x.
    Rep (SelectAssetsParams s result) x -> SelectAssetsParams s result)
-> Generic (SelectAssetsParams s result)
forall x.
Rep (SelectAssetsParams s result) x -> SelectAssetsParams s result
forall x.
SelectAssetsParams s result -> Rep (SelectAssetsParams s result) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall s result x.
Rep (SelectAssetsParams s result) x -> SelectAssetsParams s result
forall s result x.
SelectAssetsParams s result -> Rep (SelectAssetsParams s result) x
$cto :: forall s result x.
Rep (SelectAssetsParams s result) x -> SelectAssetsParams s result
$cfrom :: forall s result x.
SelectAssetsParams s result -> Rep (SelectAssetsParams s result) x
Generic

-- | Selects assets from a wallet.
--
-- This function has the following responsibilities:
--
--  - selecting inputs from the UTxO set to pay for user-specified outputs;
--  - selecting inputs from the UTxO set to pay for collateral;
--  - producing change outputs to return excess value to the wallet;
--  - balancing a selection to pay for the transaction fee.
--
-- When selecting inputs to pay for user-specified outputs, inputs are selected
-- randomly.
--
-- By default, the seed used for random selection is derived automatically,
-- from the given 'MonadRandom' context.
--
-- However, if a concrete value is specified for the optional 'randomSeed'
-- parameter, then that value will be used instead as the seed for random
-- selection.
--
selectAssets
    :: forall ctx m s k result.
        ( BoundedAddressLength k
        , HasTransactionLayer k ctx
        , HasLogger m WalletWorkerLog ctx
        , MonadRandom m
        )
    => ctx
    -> Cardano.AnyCardanoEra
    -> ProtocolParameters
    -> SelectAssetsParams s result
    -> (s -> Selection -> result)
    -> ExceptT ErrSelectAssets m result
selectAssets :: ctx
-> AnyCardanoEra
-> ProtocolParameters
-> SelectAssetsParams s result
-> (s -> Selection -> result)
-> ExceptT ErrSelectAssets m result
selectAssets ctx
ctx AnyCardanoEra
era ProtocolParameters
pp SelectAssetsParams s result
params s -> Selection -> result
transform = do
    ExceptT ErrSelectAssets m ()
guardPendingWithdrawal
    m () -> ExceptT ErrSelectAssets m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT ErrSelectAssets m ())
-> m () -> ExceptT ErrSelectAssets m ()
forall a b. (a -> b) -> a -> b
$ Tracer m WalletLog -> WalletLog -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m WalletLog
tr (WalletLog -> m ()) -> WalletLog -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> [TxOut] -> WalletLog
MsgSelectionStart
        (UTxOSelection WalletUTxO -> Int
forall (s :: * -> *) u. IsUTxOSelection s u => s u -> Int
UTxOSelection.availableSize
            (UTxOSelection WalletUTxO -> Int)
-> UTxOSelection WalletUTxO -> Int
forall a b. (a -> b) -> a -> b
$ SelectAssetsParams s result
params SelectAssetsParams s result
-> ((UTxOSelection WalletUTxO
     -> Const (UTxOSelection WalletUTxO) (UTxOSelection WalletUTxO))
    -> SelectAssetsParams s result
    -> Const (UTxOSelection WalletUTxO) (SelectAssetsParams s result))
-> UTxOSelection WalletUTxO
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "utxoAvailableForInputs"
  ((UTxOSelection WalletUTxO
    -> Const (UTxOSelection WalletUTxO) (UTxOSelection WalletUTxO))
   -> SelectAssetsParams s result
   -> Const (UTxOSelection WalletUTxO) (SelectAssetsParams s result))
(UTxOSelection WalletUTxO
 -> Const (UTxOSelection WalletUTxO) (UTxOSelection WalletUTxO))
-> SelectAssetsParams s result
-> Const (UTxOSelection WalletUTxO) (SelectAssetsParams s result)
#utxoAvailableForInputs)
        (SelectAssetsParams s result
params SelectAssetsParams s result
-> (([TxOut] -> Const [TxOut] [TxOut])
    -> SelectAssetsParams s result
    -> Const [TxOut] (SelectAssetsParams s result))
-> [TxOut]
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "outputs"
  (([TxOut] -> Const [TxOut] [TxOut])
   -> SelectAssetsParams s result
   -> Const [TxOut] (SelectAssetsParams s result))
([TxOut] -> Const [TxOut] [TxOut])
-> SelectAssetsParams s result
-> Const [TxOut] (SelectAssetsParams s result)
#outputs)
    let selectionConstraints :: SelectionConstraints
selectionConstraints = SelectionConstraints :: (TokenBundle -> TokenBundleSizeAssessment)
-> Coin
-> (Address -> TokenMap -> Coin)
-> (Address -> TokenBundle -> Bool)
-> (SelectionSkeleton -> Coin)
-> ([TxOut] -> SelectionLimit)
-> Int
-> Natural
-> Address
-> SelectionConstraints
SelectionConstraints
            { $sel:assessTokenBundleSize:SelectionConstraints :: TokenBundle -> TokenBundleSizeAssessment
assessTokenBundleSize =
                (((TokenBundle -> TokenBundleSizeAssessment)
  -> Const
       (TokenBundle -> TokenBundleSizeAssessment)
       (TokenBundle -> TokenBundleSizeAssessment))
 -> TokenBundleSizeAssessor
 -> Const
      (TokenBundle -> TokenBundleSizeAssessment) TokenBundleSizeAssessor)
-> TokenBundleSizeAssessor
-> TokenBundle
-> TokenBundleSizeAssessment
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "assessTokenBundleSize"
  (((TokenBundle -> TokenBundleSizeAssessment)
    -> Const
         (TokenBundle -> TokenBundleSizeAssessment)
         (TokenBundle -> TokenBundleSizeAssessment))
   -> TokenBundleSizeAssessor
   -> Const
        (TokenBundle -> TokenBundleSizeAssessment) TokenBundleSizeAssessor)
((TokenBundle -> TokenBundleSizeAssessment)
 -> Const
      (TokenBundle -> TokenBundleSizeAssessment)
      (TokenBundle -> TokenBundleSizeAssessment))
-> TokenBundleSizeAssessor
-> Const
     (TokenBundle -> TokenBundleSizeAssessment) TokenBundleSizeAssessor
#assessTokenBundleSize (TokenBundleSizeAssessor
 -> TokenBundle -> TokenBundleSizeAssessment)
-> TokenBundleSizeAssessor
-> TokenBundle
-> TokenBundleSizeAssessment
forall a b. (a -> b) -> a -> b
$
                TransactionLayer k SealedTx
-> TokenBundleMaxSize -> TokenBundleSizeAssessor
forall (k :: Depth -> * -> *) tx.
TransactionLayer k tx
-> TokenBundleMaxSize -> TokenBundleSizeAssessor
tokenBundleSizeAssessor TransactionLayer k SealedTx
tl (TokenBundleMaxSize -> TokenBundleSizeAssessor)
-> TokenBundleMaxSize -> TokenBundleSizeAssessor
forall a b. (a -> b) -> a -> b
$
                ProtocolParameters
pp ProtocolParameters
-> ((TokenBundleMaxSize
     -> Const TokenBundleMaxSize TokenBundleMaxSize)
    -> ProtocolParameters
    -> Const TokenBundleMaxSize ProtocolParameters)
-> TokenBundleMaxSize
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. (IsLabel
  "txParameters"
  ((TxParameters -> Const TokenBundleMaxSize TxParameters)
   -> ProtocolParameters
   -> Const TokenBundleMaxSize ProtocolParameters)
(TxParameters -> Const TokenBundleMaxSize TxParameters)
-> ProtocolParameters
-> Const TokenBundleMaxSize ProtocolParameters
#txParameters ((TxParameters -> Const TokenBundleMaxSize TxParameters)
 -> ProtocolParameters
 -> Const TokenBundleMaxSize ProtocolParameters)
-> ((TokenBundleMaxSize
     -> Const TokenBundleMaxSize TokenBundleMaxSize)
    -> TxParameters -> Const TokenBundleMaxSize TxParameters)
-> (TokenBundleMaxSize
    -> Const TokenBundleMaxSize TokenBundleMaxSize)
-> ProtocolParameters
-> Const TokenBundleMaxSize ProtocolParameters
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IsLabel
  "getTokenBundleMaxSize"
  ((TokenBundleMaxSize
    -> Const TokenBundleMaxSize TokenBundleMaxSize)
   -> TxParameters -> Const TokenBundleMaxSize TxParameters)
(TokenBundleMaxSize -> Const TokenBundleMaxSize TokenBundleMaxSize)
-> TxParameters -> Const TokenBundleMaxSize TxParameters
#getTokenBundleMaxSize)
            , $sel:certificateDepositAmount:SelectionConstraints :: Coin
certificateDepositAmount =
                ((Coin -> Const Coin Coin)
 -> ProtocolParameters -> Const Coin ProtocolParameters)
-> ProtocolParameters -> Coin
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "stakeKeyDeposit"
  ((Coin -> Const Coin Coin)
   -> ProtocolParameters -> Const Coin ProtocolParameters)
(Coin -> Const Coin Coin)
-> ProtocolParameters -> Const Coin ProtocolParameters
#stakeKeyDeposit ProtocolParameters
pp
            , $sel:computeMinimumAdaQuantity:SelectionConstraints :: Address -> TokenMap -> Coin
computeMinimumAdaQuantity =
                (((Address -> TokenMap -> Coin)
  -> Const
       (Address -> TokenMap -> Coin) (Address -> TokenMap -> Coin))
 -> TxConstraints
 -> Const (Address -> TokenMap -> Coin) TxConstraints)
-> TxConstraints -> Address -> TokenMap -> Coin
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "txOutputMinimumAdaQuantity"
  (((Address -> TokenMap -> Coin)
    -> Const
         (Address -> TokenMap -> Coin) (Address -> TokenMap -> Coin))
   -> TxConstraints
   -> Const (Address -> TokenMap -> Coin) TxConstraints)
((Address -> TokenMap -> Coin)
 -> Const
      (Address -> TokenMap -> Coin) (Address -> TokenMap -> Coin))
-> TxConstraints
-> Const (Address -> TokenMap -> Coin) TxConstraints
#txOutputMinimumAdaQuantity
                    (TransactionLayer k SealedTx
-> AnyCardanoEra -> ProtocolParameters -> TxConstraints
forall (k :: Depth -> * -> *) tx.
TransactionLayer k tx
-> AnyCardanoEra -> ProtocolParameters -> TxConstraints
constraints TransactionLayer k SealedTx
tl AnyCardanoEra
era ProtocolParameters
pp)
            , $sel:isBelowMinimumAdaQuantity:SelectionConstraints :: Address -> TokenBundle -> Bool
isBelowMinimumAdaQuantity =
                (((Address -> TokenBundle -> Bool)
  -> Const
       (Address -> TokenBundle -> Bool) (Address -> TokenBundle -> Bool))
 -> TxConstraints
 -> Const (Address -> TokenBundle -> Bool) TxConstraints)
-> TxConstraints -> Address -> TokenBundle -> Bool
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "txOutputBelowMinimumAdaQuantity"
  (((Address -> TokenBundle -> Bool)
    -> Const
         (Address -> TokenBundle -> Bool) (Address -> TokenBundle -> Bool))
   -> TxConstraints
   -> Const (Address -> TokenBundle -> Bool) TxConstraints)
((Address -> TokenBundle -> Bool)
 -> Const
      (Address -> TokenBundle -> Bool) (Address -> TokenBundle -> Bool))
-> TxConstraints
-> Const (Address -> TokenBundle -> Bool) TxConstraints
#txOutputBelowMinimumAdaQuantity
                    (TransactionLayer k SealedTx
-> AnyCardanoEra -> ProtocolParameters -> TxConstraints
forall (k :: Depth -> * -> *) tx.
TransactionLayer k tx
-> AnyCardanoEra -> ProtocolParameters -> TxConstraints
constraints TransactionLayer k SealedTx
tl AnyCardanoEra
era ProtocolParameters
pp)
            , $sel:computeMinimumCost:SelectionConstraints :: SelectionSkeleton -> Coin
computeMinimumCost =
                TransactionLayer k SealedTx
-> AnyCardanoEra
-> ProtocolParameters
-> TransactionCtx
-> SelectionSkeleton
-> Coin
forall (k :: Depth -> * -> *) tx.
TransactionLayer k tx
-> AnyCardanoEra
-> ProtocolParameters
-> TransactionCtx
-> SelectionSkeleton
-> Coin
calcMinimumCost TransactionLayer k SealedTx
tl AnyCardanoEra
era ProtocolParameters
pp (TransactionCtx -> SelectionSkeleton -> Coin)
-> TransactionCtx -> SelectionSkeleton -> Coin
forall a b. (a -> b) -> a -> b
$ SelectAssetsParams s result
params SelectAssetsParams s result
-> ((TransactionCtx -> Const TransactionCtx TransactionCtx)
    -> SelectAssetsParams s result
    -> Const TransactionCtx (SelectAssetsParams s result))
-> TransactionCtx
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "txContext"
  ((TransactionCtx -> Const TransactionCtx TransactionCtx)
   -> SelectAssetsParams s result
   -> Const TransactionCtx (SelectAssetsParams s result))
(TransactionCtx -> Const TransactionCtx TransactionCtx)
-> SelectAssetsParams s result
-> Const TransactionCtx (SelectAssetsParams s result)
#txContext
            , $sel:computeSelectionLimit:SelectionConstraints :: [TxOut] -> SelectionLimit
computeSelectionLimit =
                TransactionLayer k SealedTx
-> AnyCardanoEra
-> ProtocolParameters
-> TransactionCtx
-> [TxOut]
-> SelectionLimit
forall (k :: Depth -> * -> *) tx.
TransactionLayer k tx
-> AnyCardanoEra
-> ProtocolParameters
-> TransactionCtx
-> [TxOut]
-> SelectionLimit
Cardano.Wallet.Transaction.computeSelectionLimit
                    TransactionLayer k SealedTx
tl AnyCardanoEra
era ProtocolParameters
pp (TransactionCtx -> [TxOut] -> SelectionLimit)
-> TransactionCtx -> [TxOut] -> SelectionLimit
forall a b. (a -> b) -> a -> b
$ SelectAssetsParams s result
params SelectAssetsParams s result
-> ((TransactionCtx -> Const TransactionCtx TransactionCtx)
    -> SelectAssetsParams s result
    -> Const TransactionCtx (SelectAssetsParams s result))
-> TransactionCtx
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "txContext"
  ((TransactionCtx -> Const TransactionCtx TransactionCtx)
   -> SelectAssetsParams s result
   -> Const TransactionCtx (SelectAssetsParams s result))
(TransactionCtx -> Const TransactionCtx TransactionCtx)
-> SelectAssetsParams s result
-> Const TransactionCtx (SelectAssetsParams s result)
#txContext
            , $sel:maximumCollateralInputCount:SelectionConstraints :: Int
maximumCollateralInputCount =
                (Integral Word16, Integral Int, IsIntSubType Word16 Int ~ 'True) =>
Word16 -> Int
forall a b.
(Integral a, Integral b, IsIntSubType a b ~ 'True) =>
a -> b
intCast @Word16 @Int (Word16 -> Int) -> Word16 -> Int
forall a b. (a -> b) -> a -> b
$ ((Word16 -> Const Word16 Word16)
 -> ProtocolParameters -> Const Word16 ProtocolParameters)
-> ProtocolParameters -> Word16
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "maximumCollateralInputCount"
  ((Word16 -> Const Word16 Word16)
   -> ProtocolParameters -> Const Word16 ProtocolParameters)
(Word16 -> Const Word16 Word16)
-> ProtocolParameters -> Const Word16 ProtocolParameters
#maximumCollateralInputCount ProtocolParameters
pp
            , $sel:minimumCollateralPercentage:SelectionConstraints :: Natural
minimumCollateralPercentage =
                ((Natural -> Const Natural Natural)
 -> ProtocolParameters -> Const Natural ProtocolParameters)
-> ProtocolParameters -> Natural
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "minimumCollateralPercentage"
  ((Natural -> Const Natural Natural)
   -> ProtocolParameters -> Const Natural ProtocolParameters)
(Natural -> Const Natural Natural)
-> ProtocolParameters -> Const Natural ProtocolParameters
#minimumCollateralPercentage ProtocolParameters
pp
            , $sel:maximumLengthChangeAddress:SelectionConstraints :: Address
maximumLengthChangeAddress =
                Proxy k -> Address
forall k (key :: k).
BoundedAddressLength key =>
Proxy key -> Address
maxLengthAddressFor (Proxy k -> Address) -> Proxy k -> Address
forall a b. (a -> b) -> a -> b
$ Proxy k
forall k (t :: k). Proxy t
Proxy @k
            }
    let selectionParams :: SelectionParams
selectionParams = SelectionParams :: TokenMap
-> TokenMap
-> Coin
-> Coin
-> [TxOut]
-> Coin
-> Natural
-> Natural
-> SelectionCollateralRequirement
-> Map WalletUTxO TokenBundle
-> UTxOSelection WalletUTxO
-> SelectionStrategy
-> SelectionParams
SelectionParams
            { $sel:assetsToMint:SelectionParams :: TokenMap
assetsToMint =
                (TokenMap, Map AssetId (Script KeyHash)) -> TokenMap
forall a b. (a, b) -> a
fst ((TokenMap, Map AssetId (Script KeyHash)) -> TokenMap)
-> (TokenMap, Map AssetId (Script KeyHash)) -> TokenMap
forall a b. (a -> b) -> a -> b
$ SelectAssetsParams s result
params SelectAssetsParams s result
-> (((TokenMap, Map AssetId (Script KeyHash))
     -> Const
          (TokenMap, Map AssetId (Script KeyHash))
          (TokenMap, Map AssetId (Script KeyHash)))
    -> SelectAssetsParams s result
    -> Const
         (TokenMap, Map AssetId (Script KeyHash))
         (SelectAssetsParams s result))
-> (TokenMap, Map AssetId (Script KeyHash))
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. (IsLabel
  "txContext"
  ((TransactionCtx
    -> Const (TokenMap, Map AssetId (Script KeyHash)) TransactionCtx)
   -> SelectAssetsParams s result
   -> Const
        (TokenMap, Map AssetId (Script KeyHash))
        (SelectAssetsParams s result))
(TransactionCtx
 -> Const (TokenMap, Map AssetId (Script KeyHash)) TransactionCtx)
-> SelectAssetsParams s result
-> Const
     (TokenMap, Map AssetId (Script KeyHash))
     (SelectAssetsParams s result)
#txContext ((TransactionCtx
  -> Const (TokenMap, Map AssetId (Script KeyHash)) TransactionCtx)
 -> SelectAssetsParams s result
 -> Const
      (TokenMap, Map AssetId (Script KeyHash))
      (SelectAssetsParams s result))
-> (((TokenMap, Map AssetId (Script KeyHash))
     -> Const
          (TokenMap, Map AssetId (Script KeyHash))
          (TokenMap, Map AssetId (Script KeyHash)))
    -> TransactionCtx
    -> Const (TokenMap, Map AssetId (Script KeyHash)) TransactionCtx)
-> ((TokenMap, Map AssetId (Script KeyHash))
    -> Const
         (TokenMap, Map AssetId (Script KeyHash))
         (TokenMap, Map AssetId (Script KeyHash)))
-> SelectAssetsParams s result
-> Const
     (TokenMap, Map AssetId (Script KeyHash))
     (SelectAssetsParams s result)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IsLabel
  "txAssetsToMint"
  (((TokenMap, Map AssetId (Script KeyHash))
    -> Const
         (TokenMap, Map AssetId (Script KeyHash))
         (TokenMap, Map AssetId (Script KeyHash)))
   -> TransactionCtx
   -> Const (TokenMap, Map AssetId (Script KeyHash)) TransactionCtx)
((TokenMap, Map AssetId (Script KeyHash))
 -> Const
      (TokenMap, Map AssetId (Script KeyHash))
      (TokenMap, Map AssetId (Script KeyHash)))
-> TransactionCtx
-> Const (TokenMap, Map AssetId (Script KeyHash)) TransactionCtx
#txAssetsToMint)
            , $sel:assetsToBurn:SelectionParams :: TokenMap
assetsToBurn =
                (TokenMap, Map AssetId (Script KeyHash)) -> TokenMap
forall a b. (a, b) -> a
fst ((TokenMap, Map AssetId (Script KeyHash)) -> TokenMap)
-> (TokenMap, Map AssetId (Script KeyHash)) -> TokenMap
forall a b. (a -> b) -> a -> b
$ SelectAssetsParams s result
params SelectAssetsParams s result
-> (((TokenMap, Map AssetId (Script KeyHash))
     -> Const
          (TokenMap, Map AssetId (Script KeyHash))
          (TokenMap, Map AssetId (Script KeyHash)))
    -> SelectAssetsParams s result
    -> Const
         (TokenMap, Map AssetId (Script KeyHash))
         (SelectAssetsParams s result))
-> (TokenMap, Map AssetId (Script KeyHash))
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. (IsLabel
  "txContext"
  ((TransactionCtx
    -> Const (TokenMap, Map AssetId (Script KeyHash)) TransactionCtx)
   -> SelectAssetsParams s result
   -> Const
        (TokenMap, Map AssetId (Script KeyHash))
        (SelectAssetsParams s result))
(TransactionCtx
 -> Const (TokenMap, Map AssetId (Script KeyHash)) TransactionCtx)
-> SelectAssetsParams s result
-> Const
     (TokenMap, Map AssetId (Script KeyHash))
     (SelectAssetsParams s result)
#txContext ((TransactionCtx
  -> Const (TokenMap, Map AssetId (Script KeyHash)) TransactionCtx)
 -> SelectAssetsParams s result
 -> Const
      (TokenMap, Map AssetId (Script KeyHash))
      (SelectAssetsParams s result))
-> (((TokenMap, Map AssetId (Script KeyHash))
     -> Const
          (TokenMap, Map AssetId (Script KeyHash))
          (TokenMap, Map AssetId (Script KeyHash)))
    -> TransactionCtx
    -> Const (TokenMap, Map AssetId (Script KeyHash)) TransactionCtx)
-> ((TokenMap, Map AssetId (Script KeyHash))
    -> Const
         (TokenMap, Map AssetId (Script KeyHash))
         (TokenMap, Map AssetId (Script KeyHash)))
-> SelectAssetsParams s result
-> Const
     (TokenMap, Map AssetId (Script KeyHash))
     (SelectAssetsParams s result)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IsLabel
  "txAssetsToBurn"
  (((TokenMap, Map AssetId (Script KeyHash))
    -> Const
         (TokenMap, Map AssetId (Script KeyHash))
         (TokenMap, Map AssetId (Script KeyHash)))
   -> TransactionCtx
   -> Const (TokenMap, Map AssetId (Script KeyHash)) TransactionCtx)
((TokenMap, Map AssetId (Script KeyHash))
 -> Const
      (TokenMap, Map AssetId (Script KeyHash))
      (TokenMap, Map AssetId (Script KeyHash)))
-> TransactionCtx
-> Const (TokenMap, Map AssetId (Script KeyHash)) TransactionCtx
#txAssetsToBurn)
            , $sel:extraCoinIn:SelectionParams :: Coin
extraCoinIn = Natural -> Coin
Coin Natural
0
            , $sel:extraCoinOut:SelectionParams :: Coin
extraCoinOut = Natural -> Coin
Coin Natural
0
            , $sel:outputsToCover:SelectionParams :: [TxOut]
outputsToCover = SelectAssetsParams s result
params SelectAssetsParams s result
-> (([TxOut] -> Const [TxOut] [TxOut])
    -> SelectAssetsParams s result
    -> Const [TxOut] (SelectAssetsParams s result))
-> [TxOut]
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "outputs"
  (([TxOut] -> Const [TxOut] [TxOut])
   -> SelectAssetsParams s result
   -> Const [TxOut] (SelectAssetsParams s result))
([TxOut] -> Const [TxOut] [TxOut])
-> SelectAssetsParams s result
-> Const [TxOut] (SelectAssetsParams s result)
#outputs
            , $sel:rewardWithdrawal:SelectionParams :: Coin
rewardWithdrawal =
                Withdrawal -> Coin
withdrawalToCoin (Withdrawal -> Coin) -> Withdrawal -> Coin
forall a b. (a -> b) -> a -> b
$ SelectAssetsParams s result
params SelectAssetsParams s result
-> ((Withdrawal -> Const Withdrawal Withdrawal)
    -> SelectAssetsParams s result
    -> Const Withdrawal (SelectAssetsParams s result))
-> Withdrawal
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. (IsLabel
  "txContext"
  ((TransactionCtx -> Const Withdrawal TransactionCtx)
   -> SelectAssetsParams s result
   -> Const Withdrawal (SelectAssetsParams s result))
(TransactionCtx -> Const Withdrawal TransactionCtx)
-> SelectAssetsParams s result
-> Const Withdrawal (SelectAssetsParams s result)
#txContext ((TransactionCtx -> Const Withdrawal TransactionCtx)
 -> SelectAssetsParams s result
 -> Const Withdrawal (SelectAssetsParams s result))
-> ((Withdrawal -> Const Withdrawal Withdrawal)
    -> TransactionCtx -> Const Withdrawal TransactionCtx)
-> (Withdrawal -> Const Withdrawal Withdrawal)
-> SelectAssetsParams s result
-> Const Withdrawal (SelectAssetsParams s result)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IsLabel
  "txWithdrawal"
  ((Withdrawal -> Const Withdrawal Withdrawal)
   -> TransactionCtx -> Const Withdrawal TransactionCtx)
(Withdrawal -> Const Withdrawal Withdrawal)
-> TransactionCtx -> Const Withdrawal TransactionCtx
#txWithdrawal)
            , $sel:certificateDepositsReturned:SelectionParams :: Natural
certificateDepositsReturned =
                case SelectAssetsParams s result
params SelectAssetsParams s result
-> ((Maybe DelegationAction
     -> Const (Maybe DelegationAction) (Maybe DelegationAction))
    -> SelectAssetsParams s result
    -> Const (Maybe DelegationAction) (SelectAssetsParams s result))
-> Maybe DelegationAction
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. (IsLabel
  "txContext"
  ((TransactionCtx -> Const (Maybe DelegationAction) TransactionCtx)
   -> SelectAssetsParams s result
   -> Const (Maybe DelegationAction) (SelectAssetsParams s result))
(TransactionCtx -> Const (Maybe DelegationAction) TransactionCtx)
-> SelectAssetsParams s result
-> Const (Maybe DelegationAction) (SelectAssetsParams s result)
#txContext ((TransactionCtx -> Const (Maybe DelegationAction) TransactionCtx)
 -> SelectAssetsParams s result
 -> Const (Maybe DelegationAction) (SelectAssetsParams s result))
-> ((Maybe DelegationAction
     -> Const (Maybe DelegationAction) (Maybe DelegationAction))
    -> TransactionCtx -> Const (Maybe DelegationAction) TransactionCtx)
-> (Maybe DelegationAction
    -> Const (Maybe DelegationAction) (Maybe DelegationAction))
-> SelectAssetsParams s result
-> Const (Maybe DelegationAction) (SelectAssetsParams s result)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IsLabel
  "txDelegationAction"
  ((Maybe DelegationAction
    -> Const (Maybe DelegationAction) (Maybe DelegationAction))
   -> TransactionCtx -> Const (Maybe DelegationAction) TransactionCtx)
(Maybe DelegationAction
 -> Const (Maybe DelegationAction) (Maybe DelegationAction))
-> TransactionCtx -> Const (Maybe DelegationAction) TransactionCtx
#txDelegationAction) of
                    Just DelegationAction
Quit -> Natural
1
                    Maybe DelegationAction
_ -> Natural
0
            , $sel:certificateDepositsTaken:SelectionParams :: Natural
certificateDepositsTaken =
                case SelectAssetsParams s result
params SelectAssetsParams s result
-> ((Maybe DelegationAction
     -> Const (Maybe DelegationAction) (Maybe DelegationAction))
    -> SelectAssetsParams s result
    -> Const (Maybe DelegationAction) (SelectAssetsParams s result))
-> Maybe DelegationAction
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. (IsLabel
  "txContext"
  ((TransactionCtx -> Const (Maybe DelegationAction) TransactionCtx)
   -> SelectAssetsParams s result
   -> Const (Maybe DelegationAction) (SelectAssetsParams s result))
(TransactionCtx -> Const (Maybe DelegationAction) TransactionCtx)
-> SelectAssetsParams s result
-> Const (Maybe DelegationAction) (SelectAssetsParams s result)
#txContext ((TransactionCtx -> Const (Maybe DelegationAction) TransactionCtx)
 -> SelectAssetsParams s result
 -> Const (Maybe DelegationAction) (SelectAssetsParams s result))
-> ((Maybe DelegationAction
     -> Const (Maybe DelegationAction) (Maybe DelegationAction))
    -> TransactionCtx -> Const (Maybe DelegationAction) TransactionCtx)
-> (Maybe DelegationAction
    -> Const (Maybe DelegationAction) (Maybe DelegationAction))
-> SelectAssetsParams s result
-> Const (Maybe DelegationAction) (SelectAssetsParams s result)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IsLabel
  "txDelegationAction"
  ((Maybe DelegationAction
    -> Const (Maybe DelegationAction) (Maybe DelegationAction))
   -> TransactionCtx -> Const (Maybe DelegationAction) TransactionCtx)
(Maybe DelegationAction
 -> Const (Maybe DelegationAction) (Maybe DelegationAction))
-> TransactionCtx -> Const (Maybe DelegationAction) TransactionCtx
#txDelegationAction) of
                    Just (RegisterKeyAndJoin PoolId
_) -> Natural
1
                    Maybe DelegationAction
_ -> Natural
0
            , $sel:collateralRequirement:SelectionParams :: SelectionCollateralRequirement
collateralRequirement =
                SelectAssetsParams s result
params SelectAssetsParams s result
-> ((SelectionCollateralRequirement
     -> Const
          SelectionCollateralRequirement SelectionCollateralRequirement)
    -> SelectAssetsParams s result
    -> Const
         SelectionCollateralRequirement (SelectAssetsParams s result))
-> SelectionCollateralRequirement
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. (IsLabel
  "txContext"
  ((TransactionCtx
    -> Const SelectionCollateralRequirement TransactionCtx)
   -> SelectAssetsParams s result
   -> Const
        SelectionCollateralRequirement (SelectAssetsParams s result))
(TransactionCtx
 -> Const SelectionCollateralRequirement TransactionCtx)
-> SelectAssetsParams s result
-> Const
     SelectionCollateralRequirement (SelectAssetsParams s result)
#txContext ((TransactionCtx
  -> Const SelectionCollateralRequirement TransactionCtx)
 -> SelectAssetsParams s result
 -> Const
      SelectionCollateralRequirement (SelectAssetsParams s result))
-> ((SelectionCollateralRequirement
     -> Const
          SelectionCollateralRequirement SelectionCollateralRequirement)
    -> TransactionCtx
    -> Const SelectionCollateralRequirement TransactionCtx)
-> (SelectionCollateralRequirement
    -> Const
         SelectionCollateralRequirement SelectionCollateralRequirement)
-> SelectAssetsParams s result
-> Const
     SelectionCollateralRequirement (SelectAssetsParams s result)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IsLabel
  "txCollateralRequirement"
  ((SelectionCollateralRequirement
    -> Const
         SelectionCollateralRequirement SelectionCollateralRequirement)
   -> TransactionCtx
   -> Const SelectionCollateralRequirement TransactionCtx)
(SelectionCollateralRequirement
 -> Const
      SelectionCollateralRequirement SelectionCollateralRequirement)
-> TransactionCtx
-> Const SelectionCollateralRequirement TransactionCtx
#txCollateralRequirement)
            , $sel:utxoAvailableForCollateral:SelectionParams :: Map WalletUTxO TokenBundle
utxoAvailableForCollateral =
                SelectAssetsParams s result
params SelectAssetsParams s result
-> ((Map WalletUTxO TokenBundle
     -> Const (Map WalletUTxO TokenBundle) (Map WalletUTxO TokenBundle))
    -> SelectAssetsParams s result
    -> Const
         (Map WalletUTxO TokenBundle) (SelectAssetsParams s result))
-> Map WalletUTxO TokenBundle
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "utxoAvailableForCollateral"
  ((Map WalletUTxO TokenBundle
    -> Const (Map WalletUTxO TokenBundle) (Map WalletUTxO TokenBundle))
   -> SelectAssetsParams s result
   -> Const
        (Map WalletUTxO TokenBundle) (SelectAssetsParams s result))
(Map WalletUTxO TokenBundle
 -> Const (Map WalletUTxO TokenBundle) (Map WalletUTxO TokenBundle))
-> SelectAssetsParams s result
-> Const (Map WalletUTxO TokenBundle) (SelectAssetsParams s result)
#utxoAvailableForCollateral
            , $sel:utxoAvailableForInputs:SelectionParams :: UTxOSelection WalletUTxO
utxoAvailableForInputs =
                SelectAssetsParams s result
params SelectAssetsParams s result
-> ((UTxOSelection WalletUTxO
     -> Const (UTxOSelection WalletUTxO) (UTxOSelection WalletUTxO))
    -> SelectAssetsParams s result
    -> Const (UTxOSelection WalletUTxO) (SelectAssetsParams s result))
-> UTxOSelection WalletUTxO
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "utxoAvailableForInputs"
  ((UTxOSelection WalletUTxO
    -> Const (UTxOSelection WalletUTxO) (UTxOSelection WalletUTxO))
   -> SelectAssetsParams s result
   -> Const (UTxOSelection WalletUTxO) (SelectAssetsParams s result))
(UTxOSelection WalletUTxO
 -> Const (UTxOSelection WalletUTxO) (UTxOSelection WalletUTxO))
-> SelectAssetsParams s result
-> Const (UTxOSelection WalletUTxO) (SelectAssetsParams s result)
#utxoAvailableForInputs
            , $sel:selectionStrategy:SelectionParams :: SelectionStrategy
selectionStrategy =
                ((SelectionStrategy -> Const SelectionStrategy SelectionStrategy)
 -> SelectAssetsParams s result
 -> Const SelectionStrategy (SelectAssetsParams s result))
-> SelectAssetsParams s result -> SelectionStrategy
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "selectionStrategy"
  ((SelectionStrategy -> Const SelectionStrategy SelectionStrategy)
   -> SelectAssetsParams s result
   -> Const SelectionStrategy (SelectAssetsParams s result))
(SelectionStrategy -> Const SelectionStrategy SelectionStrategy)
-> SelectAssetsParams s result
-> Const SelectionStrategy (SelectAssetsParams s result)
#selectionStrategy SelectAssetsParams s result
params
            }
    StdGenSeed
randomSeed <- ExceptT ErrSelectAssets m StdGenSeed
-> (StdGenSeed -> ExceptT ErrSelectAssets m StdGenSeed)
-> Maybe StdGenSeed
-> ExceptT ErrSelectAssets m StdGenSeed
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ExceptT ErrSelectAssets m StdGenSeed
forall (m :: * -> *). MonadRandom m => m StdGenSeed
stdGenSeed StdGenSeed -> ExceptT ErrSelectAssets m StdGenSeed
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SelectAssetsParams s result
params SelectAssetsParams s result
-> ((Maybe StdGenSeed
     -> Const (Maybe StdGenSeed) (Maybe StdGenSeed))
    -> SelectAssetsParams s result
    -> Const (Maybe StdGenSeed) (SelectAssetsParams s result))
-> Maybe StdGenSeed
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "randomSeed"
  ((Maybe StdGenSeed -> Const (Maybe StdGenSeed) (Maybe StdGenSeed))
   -> SelectAssetsParams s result
   -> Const (Maybe StdGenSeed) (SelectAssetsParams s result))
(Maybe StdGenSeed -> Const (Maybe StdGenSeed) (Maybe StdGenSeed))
-> SelectAssetsParams s result
-> Const (Maybe StdGenSeed) (SelectAssetsParams s result)
#randomSeed)
    let mSel :: Either (SelectionError WalletSelectionContext) Selection
mSel = (Rand
   StdGen (Either (SelectionError WalletSelectionContext) Selection)
 -> StdGen
 -> Either (SelectionError WalletSelectionContext) Selection)
-> StdGen
-> Rand
     StdGen (Either (SelectionError WalletSelectionContext) Selection)
-> Either (SelectionError WalletSelectionContext) Selection
forall a b c. (a -> b -> c) -> b -> a -> c
flip Rand
  StdGen (Either (SelectionError WalletSelectionContext) Selection)
-> StdGen
-> Either (SelectionError WalletSelectionContext) Selection
forall g a. Rand g a -> g -> a
evalRand (StdGenSeed -> StdGen
stdGenFromSeed StdGenSeed
randomSeed)
            (Rand
   StdGen (Either (SelectionError WalletSelectionContext) Selection)
 -> Either (SelectionError WalletSelectionContext) Selection)
-> Rand
     StdGen (Either (SelectionError WalletSelectionContext) Selection)
-> Either (SelectionError WalletSelectionContext) Selection
forall a b. (a -> b) -> a -> b
$ ExceptT
  (SelectionError WalletSelectionContext)
  (RandT StdGen Identity)
  Selection
-> Rand
     StdGen (Either (SelectionError WalletSelectionContext) Selection)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
            (ExceptT
   (SelectionError WalletSelectionContext)
   (RandT StdGen Identity)
   Selection
 -> Rand
      StdGen (Either (SelectionError WalletSelectionContext) Selection))
-> ExceptT
     (SelectionError WalletSelectionContext)
     (RandT StdGen Identity)
     Selection
-> Rand
     StdGen (Either (SelectionError WalletSelectionContext) Selection)
forall a b. (a -> b) -> a -> b
$ SelectionConstraints
-> SelectionParams
-> ExceptT
     (SelectionError WalletSelectionContext)
     (RandT StdGen Identity)
     Selection
forall (m :: * -> *).
(HasCallStack, MonadRandom m) =>
SelectionConstraints
-> SelectionParams
-> ExceptT (SelectionError WalletSelectionContext) m Selection
performSelection SelectionConstraints
selectionConstraints SelectionParams
selectionParams
    case Either (SelectionError WalletSelectionContext) Selection
mSel of
        Left SelectionError WalletSelectionContext
e -> m () -> ExceptT ErrSelectAssets m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT ErrSelectAssets m ())
-> m () -> ExceptT ErrSelectAssets m ()
forall a b. (a -> b) -> a -> b
$
            Tracer m WalletLog -> WalletLog -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m WalletLog
tr (WalletLog -> m ()) -> WalletLog -> m ()
forall a b. (a -> b) -> a -> b
$ SelectionError WalletSelectionContext -> WalletLog
MsgSelectionError SelectionError WalletSelectionContext
e
        Right Selection
sel -> m () -> ExceptT ErrSelectAssets m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT ErrSelectAssets m ())
-> m () -> ExceptT ErrSelectAssets m ()
forall a b. (a -> b) -> a -> b
$ do
            Tracer m WalletLog -> WalletLog -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m WalletLog
tr (WalletLog -> m ()) -> WalletLog -> m ()
forall a b. (a -> b) -> a -> b
$ SelectionReportSummarized -> WalletLog
MsgSelectionReportSummarized
                (SelectionReportSummarized -> WalletLog)
-> SelectionReportSummarized -> WalletLog
forall a b. (a -> b) -> a -> b
$ Selection -> SelectionReportSummarized
makeSelectionReportSummarized Selection
sel
            Tracer m WalletLog -> WalletLog -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m WalletLog
tr (WalletLog -> m ()) -> WalletLog -> m ()
forall a b. (a -> b) -> a -> b
$ SelectionReportDetailed -> WalletLog
MsgSelectionReportDetailed
                (SelectionReportDetailed -> WalletLog)
-> SelectionReportDetailed -> WalletLog
forall a b. (a -> b) -> a -> b
$ Selection -> SelectionReportDetailed
makeSelectionReportDetailed Selection
sel
    (SelectionError WalletSelectionContext -> ErrSelectAssets)
-> ExceptT (SelectionError WalletSelectionContext) m result
-> ExceptT ErrSelectAssets m result
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT SelectionError WalletSelectionContext -> ErrSelectAssets
ErrSelectAssetsSelectionError (ExceptT (SelectionError WalletSelectionContext) m result
 -> ExceptT ErrSelectAssets m result)
-> ExceptT (SelectionError WalletSelectionContext) m result
-> ExceptT ErrSelectAssets m result
forall a b. (a -> b) -> a -> b
$ Either (SelectionError WalletSelectionContext) result
-> ExceptT (SelectionError WalletSelectionContext) m result
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either (SelectionError WalletSelectionContext) result
 -> ExceptT (SelectionError WalletSelectionContext) m result)
-> Either (SelectionError WalletSelectionContext) result
-> ExceptT (SelectionError WalletSelectionContext) m result
forall a b. (a -> b) -> a -> b
$
        s -> Selection -> result
transform (Wallet s -> s
forall s. Wallet s -> s
getState (Wallet s -> s) -> Wallet s -> s
forall a b. (a -> b) -> a -> b
$ SelectAssetsParams s result
params SelectAssetsParams s result
-> ((Wallet s -> Const (Wallet s) (Wallet s))
    -> SelectAssetsParams s result
    -> Const (Wallet s) (SelectAssetsParams s result))
-> Wallet s
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "wallet"
  ((Wallet s -> Const (Wallet s) (Wallet s))
   -> SelectAssetsParams s result
   -> Const (Wallet s) (SelectAssetsParams s result))
(Wallet s -> Const (Wallet s) (Wallet s))
-> SelectAssetsParams s result
-> Const (Wallet s) (SelectAssetsParams s result)
#wallet) (Selection -> result)
-> Either (SelectionError WalletSelectionContext) Selection
-> Either (SelectionError WalletSelectionContext) result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either (SelectionError WalletSelectionContext) Selection
mSel
  where
    tl :: TransactionLayer k SealedTx
tl = ctx
ctx ctx
-> ((TransactionLayer k SealedTx
     -> Const
          (TransactionLayer k SealedTx) (TransactionLayer k SealedTx))
    -> ctx -> Const (TransactionLayer k SealedTx) ctx)
-> TransactionLayer k SealedTx
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx.
HasTransactionLayer k ctx =>
Lens' ctx (TransactionLayer k SealedTx)
forall (k :: Depth -> * -> *) ctx.
HasTransactionLayer k ctx =>
Lens' ctx (TransactionLayer k SealedTx)
transactionLayer @k
    tr :: Tracer m WalletLog
tr = (WalletLog -> WalletWorkerLog)
-> Tracer m WalletWorkerLog -> Tracer m WalletLog
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap WalletLog -> WalletWorkerLog
MsgWallet (Tracer m WalletWorkerLog -> Tracer m WalletLog)
-> Tracer m WalletWorkerLog -> Tracer m WalletLog
forall a b. (a -> b) -> a -> b
$ ctx
ctx ctx
-> ((Tracer m WalletWorkerLog
     -> Const (Tracer m WalletWorkerLog) (Tracer m WalletWorkerLog))
    -> ctx -> Const (Tracer m WalletWorkerLog) ctx)
-> Tracer m WalletWorkerLog
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall msg ctx. HasLogger m msg ctx => Lens' ctx (Tracer m msg)
forall (m :: * -> *) msg ctx.
HasLogger m msg ctx =>
Lens' ctx (Tracer m msg)
logger @m

    -- Ensure that there's no existing pending withdrawals. Indeed, a withdrawal
    -- is necessarily withdrawing rewards in their totality. So, after a first
    -- withdrawal is executed, the reward pot is empty. So, to prevent two
    -- transactions with withdrawals to go through (which will inevitably cause
    -- one of them to never be inserted), we warn users early on about it.
    guardPendingWithdrawal :: ExceptT ErrSelectAssets m ()
    guardPendingWithdrawal :: ExceptT ErrSelectAssets m ()
guardPendingWithdrawal =
        case Set Tx -> Maybe Tx
forall a. Set a -> Maybe a
Set.lookupMin (Set Tx -> Maybe Tx) -> Set Tx -> Maybe Tx
forall a b. (a -> b) -> a -> b
$ (Tx -> Bool) -> Set Tx -> Set Tx
forall a. (a -> Bool) -> Set a -> Set a
Set.filter Tx -> Bool
hasWithdrawal (Set Tx -> Set Tx) -> Set Tx -> Set Tx
forall a b. (a -> b) -> a -> b
$ SelectAssetsParams s result
params SelectAssetsParams s result
-> ((Set Tx -> Const (Set Tx) (Set Tx))
    -> SelectAssetsParams s result
    -> Const (Set Tx) (SelectAssetsParams s result))
-> Set Tx
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "pendingTxs"
  ((Set Tx -> Const (Set Tx) (Set Tx))
   -> SelectAssetsParams s result
   -> Const (Set Tx) (SelectAssetsParams s result))
(Set Tx -> Const (Set Tx) (Set Tx))
-> SelectAssetsParams s result
-> Const (Set Tx) (SelectAssetsParams s result)
#pendingTxs of
            Just Tx
pendingWithdrawal
                | Withdrawal -> Coin
withdrawalToCoin Withdrawal
txWithdrawal Coin -> Coin -> Bool
forall a. Eq a => a -> a -> Bool
/= Natural -> Coin
Coin Natural
0 ->
                    ErrSelectAssets -> ExceptT ErrSelectAssets m ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (ErrSelectAssets -> ExceptT ErrSelectAssets m ())
-> ErrSelectAssets -> ExceptT ErrSelectAssets m ()
forall a b. (a -> b) -> a -> b
$ Tx -> ErrSelectAssets
ErrSelectAssetsAlreadyWithdrawing Tx
pendingWithdrawal
            Maybe Tx
_otherwise ->
                () -> ExceptT ErrSelectAssets m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      where
        hasWithdrawal :: Tx -> Bool
        hasWithdrawal :: Tx -> Bool
hasWithdrawal = Bool -> Bool
not (Bool -> Bool) -> (Tx -> Bool) -> Tx -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map RewardAccount Coin -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Map RewardAccount Coin -> Bool)
-> (Tx -> Map RewardAccount Coin) -> Tx -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx -> Map RewardAccount Coin
withdrawals

        txWithdrawal :: Withdrawal
        txWithdrawal :: Withdrawal
txWithdrawal = SelectAssetsParams s result
params SelectAssetsParams s result
-> ((Withdrawal -> Const Withdrawal Withdrawal)
    -> SelectAssetsParams s result
    -> Const Withdrawal (SelectAssetsParams s result))
-> Withdrawal
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. (IsLabel
  "txContext"
  ((TransactionCtx -> Const Withdrawal TransactionCtx)
   -> SelectAssetsParams s result
   -> Const Withdrawal (SelectAssetsParams s result))
(TransactionCtx -> Const Withdrawal TransactionCtx)
-> SelectAssetsParams s result
-> Const Withdrawal (SelectAssetsParams s result)
#txContext ((TransactionCtx -> Const Withdrawal TransactionCtx)
 -> SelectAssetsParams s result
 -> Const Withdrawal (SelectAssetsParams s result))
-> ((Withdrawal -> Const Withdrawal Withdrawal)
    -> TransactionCtx -> Const Withdrawal TransactionCtx)
-> (Withdrawal -> Const Withdrawal Withdrawal)
-> SelectAssetsParams s result
-> Const Withdrawal (SelectAssetsParams s result)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IsLabel
  "txWithdrawal"
  ((Withdrawal -> Const Withdrawal Withdrawal)
   -> TransactionCtx -> Const Withdrawal TransactionCtx)
(Withdrawal -> Const Withdrawal Withdrawal)
-> TransactionCtx -> Const Withdrawal TransactionCtx
#txWithdrawal)

signTransaction
  :: forall k
   . ( WalletKey k
     , HardDerivation k
     , Bounded (Index (AddressIndexDerivationType k) 'AddressK)
     )
  => TransactionLayer k SealedTx
  -- ^ The way to interact with the wallet backend
  -> Cardano.AnyCardanoEra
  -- ^ Preferred latest era
  -> (Address -> Maybe (k 'AddressK XPrv, Passphrase "encryption"))
  -- ^ The wallets address-key lookup function
  -> (k 'RootK XPrv, Passphrase "encryption")
  -- ^ The root key of the wallet
  -> UTxO
  -- ^ The total UTxO set of the wallet (i.e. if pending transactions all
  -- applied).
  -> SealedTx
  -- ^ The transaction to sign
  -> SealedTx
  -- ^ The original transaction, with additional signatures added where
  -- necessary
signTransaction :: TransactionLayer k SealedTx
-> AnyCardanoEra
-> (Address -> Maybe (k 'AddressK XPrv, Passphrase "encryption"))
-> (k 'RootK XPrv, Passphrase "encryption")
-> UTxO
-> SealedTx
-> SealedTx
signTransaction TransactionLayer k SealedTx
tl AnyCardanoEra
preferredLatestEra Address -> Maybe (k 'AddressK XPrv, Passphrase "encryption")
keyLookup (k 'RootK XPrv
rootKey, Passphrase "encryption"
rootPwd) UTxO
utxo =
    let
        rewardAcnt :: (XPrv, Passphrase "encryption")
        rewardAcnt :: (XPrv, Passphrase "encryption")
rewardAcnt =
            (k 'AddressK XPrv -> XPrv
forall (key :: Depth -> * -> *) (depth :: Depth) raw.
WalletKey key =>
key depth raw -> raw
getRawKey (k 'AddressK XPrv -> XPrv) -> k 'AddressK XPrv -> XPrv
forall a b. (a -> b) -> a -> b
$ Passphrase "encryption" -> k 'RootK XPrv -> k 'AddressK XPrv
forall (k :: Depth -> * -> *).
(HardDerivation k,
 Bounded (Index (AddressIndexDerivationType k) 'AddressK)) =>
Passphrase "encryption" -> k 'RootK XPrv -> k 'AddressK XPrv
deriveRewardAccount @k Passphrase "encryption"
rootPwd k 'RootK XPrv
rootKey, Passphrase "encryption"
rootPwd)

        policyKey :: (KeyHash, XPrv, Passphrase "encryption")
        policyKey :: (KeyHash, XPrv, Passphrase "encryption")
policyKey =
            ( KeyRole -> k Any XPub -> KeyHash
forall (key :: Depth -> * -> *) (depth :: Depth).
WalletKey key =>
KeyRole -> key depth XPub -> KeyHash
hashVerificationKey @k KeyRole
CA.Policy (k Any XPub -> KeyHash) -> k Any XPub -> KeyHash
forall a b. (a -> b) -> a -> b
$ XPub -> k Any XPub
forall (key :: Depth -> * -> *) raw (depth :: Depth).
WalletKey key =>
raw -> key depth raw
liftRawKey (XPub -> k Any XPub) -> XPub -> k Any XPub
forall a b. (a -> b) -> a -> b
$ HasCallStack => XPrv -> XPub
XPrv -> XPub
toXPub XPrv
xprv
            , XPrv
xprv
            , Passphrase "encryption"
rootPwd
            )
          where
            xprv :: XPrv
xprv = Passphrase "encryption" -> XPrv -> Index 'Hardened 'PolicyK -> XPrv
forall (purpose :: Symbol).
Passphrase purpose -> XPrv -> Index 'Hardened 'PolicyK -> XPrv
derivePolicyPrivateKey Passphrase "encryption"
rootPwd (k 'RootK XPrv -> XPrv
forall (key :: Depth -> * -> *) (depth :: Depth) raw.
WalletKey key =>
key depth raw -> raw
getRawKey k 'RootK XPrv
rootKey) Index 'Hardened 'PolicyK
forall a. Bounded a => a
minBound

        inputResolver :: TxIn -> Maybe Address
        inputResolver :: TxIn -> Maybe Address
inputResolver TxIn
i = do
            TxOut Address
addr TokenBundle
_ <- TxIn -> UTxO -> Maybe TxOut
UTxO.lookup TxIn
i UTxO
utxo
            Address -> Maybe Address
forall (f :: * -> *) a. Applicative f => a -> f a
pure Address
addr
    in
        TransactionLayer k SealedTx
-> AnyCardanoEra
-> (XPrv, Passphrase "encryption")
-> (KeyHash, XPrv, Passphrase "encryption")
-> (Address -> Maybe (k 'AddressK XPrv, Passphrase "encryption"))
-> (TxIn -> Maybe Address)
-> SealedTx
-> SealedTx
forall (k :: Depth -> * -> *) tx.
TransactionLayer k tx
-> AnyCardanoEra
-> (XPrv, Passphrase "encryption")
-> (KeyHash, XPrv, Passphrase "encryption")
-> (Address -> Maybe (k 'AddressK XPrv, Passphrase "encryption"))
-> (TxIn -> Maybe Address)
-> tx
-> tx
addVkWitnesses
            TransactionLayer k SealedTx
tl
            AnyCardanoEra
preferredLatestEra
            (XPrv, Passphrase "encryption")
rewardAcnt
            (KeyHash, XPrv, Passphrase "encryption")
policyKey
            Address -> Maybe (k 'AddressK XPrv, Passphrase "encryption")
keyLookup
            TxIn -> Maybe Address
inputResolver

-- | Produce witnesses and construct a transaction from a given selection.
--
-- Requires the encryption passphrase in order to decrypt the root private key.
-- Note that this doesn't broadcast the transaction to the network. In order to
-- do so, use 'submitTx'.
--
buildAndSignTransaction
    :: forall ctx s k.
        ( HasTransactionLayer k ctx
        , HasDBLayer IO s k ctx
        , HasNetworkLayer IO ctx
        , IsOwned s k
        )
    => ctx
    -> WalletId
    -> Cardano.AnyCardanoEra
    -> ( (k 'RootK XPrv, Passphrase "encryption") ->
         (         XPrv, Passphrase "encryption")
       )
       -- ^ Reward account derived from the root key (or somewhere else).
    -> Passphrase "user"
    -> TransactionCtx
    -> SelectionOf TxOut
    -> ExceptT ErrSignPayment IO (Tx, TxMeta, UTCTime, SealedTx)
buildAndSignTransaction :: ctx
-> WalletId
-> AnyCardanoEra
-> ((k 'RootK XPrv, Passphrase "encryption")
    -> (XPrv, Passphrase "encryption"))
-> Passphrase "user"
-> TransactionCtx
-> SelectionOf TxOut
-> ExceptT ErrSignPayment IO (Tx, TxMeta, UTCTime, SealedTx)
buildAndSignTransaction ctx
ctx WalletId
wid AnyCardanoEra
era (k 'RootK XPrv, Passphrase "encryption")
-> (XPrv, Passphrase "encryption")
mkRwdAcct Passphrase "user"
pwd TransactionCtx
txCtx SelectionOf TxOut
sel = DBLayer IO s k
db DBLayer IO s k
-> (DBLayer IO s k
    -> ExceptT ErrSignPayment IO (Tx, TxMeta, UTCTime, SealedTx))
-> ExceptT ErrSignPayment IO (Tx, TxMeta, UTCTime, SealedTx)
forall a b. a -> (a -> b) -> b
& \DBLayer{stm [WalletId]
DBVar stm (DeltaMap WalletId (DeltaWalletState s))
WalletId -> stm [LocalTxSubmissionStatus SealedTx]
WalletId -> stm [ChainPoint]
WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
WalletId -> stm (Maybe GenesisParameters)
WalletId -> stm (Maybe WalletMetadata)
WalletId -> stm (Maybe (Wallet s))
WalletId -> stm Coin
WalletId -> ExceptT ErrNoSuchWallet stm Bool
WalletId -> ExceptT ErrNoSuchWallet stm ()
WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
forall a. stm a -> IO a
atomically :: forall a. stm a -> IO a
prune :: WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
rollbackTo :: WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
readGenesisParameters :: WalletId -> stm (Maybe GenesisParameters)
readPrivateKey :: WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
putPrivateKey :: WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
removePendingOrExpiredTx :: WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
updatePendingTxForExpiry :: WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
readLocalTxSubmissionPending :: WalletId -> stm [LocalTxSubmissionStatus SealedTx]
putLocalTxSubmission :: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
getTx :: WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
readTxHistory :: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
putTxHistory :: WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
readDelegationRewardBalance :: WalletId -> stm Coin
putDelegationRewardBalance :: WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
putDelegationCertificate :: WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
isStakeKeyRegistered :: WalletId -> ExceptT ErrNoSuchWallet stm Bool
readWalletMeta :: WalletId -> stm (Maybe WalletMetadata)
putWalletMeta :: WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
listCheckpoints :: WalletId -> stm [ChainPoint]
readCheckpoint :: WalletId -> stm (Maybe (Wallet s))
putCheckpoint :: WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
walletsDB :: DBVar stm (DeltaMap WalletId (DeltaWalletState s))
listWallets :: stm [WalletId]
removeWallet :: WalletId -> ExceptT ErrNoSuchWallet stm ()
initializeWallet :: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
atomically :: ()
prune :: ()
rollbackTo :: ()
readGenesisParameters :: ()
readPrivateKey :: ()
putPrivateKey :: ()
removePendingOrExpiredTx :: ()
updatePendingTxForExpiry :: ()
readLocalTxSubmissionPending :: ()
putLocalTxSubmission :: ()
getTx :: ()
readTxHistory :: ()
putTxHistory :: ()
readDelegationRewardBalance :: ()
putDelegationRewardBalance :: ()
putDelegationCertificate :: ()
isStakeKeyRegistered :: ()
readWalletMeta :: ()
putWalletMeta :: ()
listCheckpoints :: ()
readCheckpoint :: ()
putCheckpoint :: ()
walletsDB :: ()
listWallets :: ()
removeWallet :: ()
initializeWallet :: ()
..} -> do
    ctx
-> WalletId
-> Passphrase "user"
-> (ErrWithRootKey -> ErrSignPayment)
-> (k 'RootK XPrv
    -> PassphraseScheme
    -> ExceptT ErrSignPayment IO (Tx, TxMeta, UTCTime, SealedTx))
-> ExceptT ErrSignPayment IO (Tx, TxMeta, UTCTime, SealedTx)
forall ctx s (k :: Depth -> * -> *) e a.
HasDBLayer IO s k ctx =>
ctx
-> WalletId
-> Passphrase "user"
-> (ErrWithRootKey -> e)
-> (k 'RootK XPrv -> PassphraseScheme -> ExceptT e IO a)
-> ExceptT e IO a
withRootKey @_ @s ctx
ctx WalletId
wid Passphrase "user"
pwd ErrWithRootKey -> ErrSignPayment
ErrSignPaymentWithRootKey ((k 'RootK XPrv
  -> PassphraseScheme
  -> ExceptT ErrSignPayment IO (Tx, TxMeta, UTCTime, SealedTx))
 -> ExceptT ErrSignPayment IO (Tx, TxMeta, UTCTime, SealedTx))
-> (k 'RootK XPrv
    -> PassphraseScheme
    -> ExceptT ErrSignPayment IO (Tx, TxMeta, UTCTime, SealedTx))
-> ExceptT ErrSignPayment IO (Tx, TxMeta, UTCTime, SealedTx)
forall a b. (a -> b) -> a -> b
$ \k 'RootK XPrv
xprv PassphraseScheme
scheme -> do
        let pwdP :: Passphrase "encryption"
pwdP = PassphraseScheme -> Passphrase "user" -> Passphrase "encryption"
preparePassphrase PassphraseScheme
scheme Passphrase "user"
pwd
        (stm (Either ErrSignPayment (Tx, TxMeta, UTCTime, SealedTx))
 -> IO (Either ErrSignPayment (Tx, TxMeta, UTCTime, SealedTx)))
-> ExceptT ErrSignPayment stm (Tx, TxMeta, UTCTime, SealedTx)
-> ExceptT ErrSignPayment IO (Tx, TxMeta, UTCTime, SealedTx)
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT stm (Either ErrSignPayment (Tx, TxMeta, UTCTime, SealedTx))
-> IO (Either ErrSignPayment (Tx, TxMeta, UTCTime, SealedTx))
forall a. stm a -> IO a
atomically (ExceptT ErrSignPayment stm (Tx, TxMeta, UTCTime, SealedTx)
 -> ExceptT ErrSignPayment IO (Tx, TxMeta, UTCTime, SealedTx))
-> ExceptT ErrSignPayment stm (Tx, TxMeta, UTCTime, SealedTx)
-> ExceptT ErrSignPayment IO (Tx, TxMeta, UTCTime, SealedTx)
forall a b. (a -> b) -> a -> b
$ do
            Wallet s
cp <- (ErrNoSuchWallet -> ErrSignPayment)
-> ExceptT ErrNoSuchWallet stm (Wallet s)
-> ExceptT ErrSignPayment stm (Wallet s)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ErrNoSuchWallet -> ErrSignPayment
ErrSignPaymentNoSuchWallet
                (ExceptT ErrNoSuchWallet stm (Wallet s)
 -> ExceptT ErrSignPayment stm (Wallet s))
-> ExceptT ErrNoSuchWallet stm (Wallet s)
-> ExceptT ErrSignPayment stm (Wallet s)
forall a b. (a -> b) -> a -> b
$ WalletId
-> stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s)
forall (m :: * -> *) a.
Monad m =>
WalletId -> m (Maybe a) -> ExceptT ErrNoSuchWallet m a
withNoSuchWallet WalletId
wid
                (stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s))
-> stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s)
forall a b. (a -> b) -> a -> b
$ WalletId -> stm (Maybe (Wallet s))
readCheckpoint WalletId
wid
            ProtocolParameters
pp <- IO ProtocolParameters
-> ExceptT ErrSignPayment stm ProtocolParameters
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProtocolParameters
 -> ExceptT ErrSignPayment stm ProtocolParameters)
-> IO ProtocolParameters
-> ExceptT ErrSignPayment stm ProtocolParameters
forall a b. (a -> b) -> a -> b
$ NetworkLayer IO Block -> IO ProtocolParameters
forall (m :: * -> *) block.
NetworkLayer m block -> m ProtocolParameters
currentProtocolParameters NetworkLayer IO Block
nl
            let keyFrom :: Address -> Maybe (k 'AddressK XPrv, Passphrase "encryption")
keyFrom = s
-> (k 'RootK XPrv, Passphrase "encryption")
-> Address
-> Maybe (k 'AddressK XPrv, Passphrase "encryption")
forall s (key :: Depth -> * -> *).
IsOwned s key =>
s
-> (key 'RootK XPrv, Passphrase "encryption")
-> Address
-> Maybe (key 'AddressK XPrv, Passphrase "encryption")
isOwned (Wallet s -> s
forall s. Wallet s -> s
getState Wallet s
cp) (k 'RootK XPrv
xprv, Passphrase "encryption"
pwdP)
            let rewardAcnt :: (XPrv, Passphrase "encryption")
rewardAcnt = (k 'RootK XPrv, Passphrase "encryption")
-> (XPrv, Passphrase "encryption")
mkRwdAcct (k 'RootK XPrv
xprv, Passphrase "encryption"
pwdP)
            (Tx
tx, SealedTx
sealedTx) <- (ErrMkTransaction -> ErrSignPayment)
-> ExceptT ErrMkTransaction stm (Tx, SealedTx)
-> ExceptT ErrSignPayment stm (Tx, SealedTx)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ErrMkTransaction -> ErrSignPayment
ErrSignPaymentMkTx (ExceptT ErrMkTransaction stm (Tx, SealedTx)
 -> ExceptT ErrSignPayment stm (Tx, SealedTx))
-> ExceptT ErrMkTransaction stm (Tx, SealedTx)
-> ExceptT ErrSignPayment stm (Tx, SealedTx)
forall a b. (a -> b) -> a -> b
$ stm (Either ErrMkTransaction (Tx, SealedTx))
-> ExceptT ErrMkTransaction stm (Tx, SealedTx)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (stm (Either ErrMkTransaction (Tx, SealedTx))
 -> ExceptT ErrMkTransaction stm (Tx, SealedTx))
-> stm (Either ErrMkTransaction (Tx, SealedTx))
-> ExceptT ErrMkTransaction stm (Tx, SealedTx)
forall a b. (a -> b) -> a -> b
$ Either ErrMkTransaction (Tx, SealedTx)
-> stm (Either ErrMkTransaction (Tx, SealedTx))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrMkTransaction (Tx, SealedTx)
 -> stm (Either ErrMkTransaction (Tx, SealedTx)))
-> Either ErrMkTransaction (Tx, SealedTx)
-> stm (Either ErrMkTransaction (Tx, SealedTx))
forall a b. (a -> b) -> a -> b
$
                TransactionLayer k SealedTx
-> AnyCardanoEra
-> (XPrv, Passphrase "encryption")
-> (Address -> Maybe (k 'AddressK XPrv, Passphrase "encryption"))
-> ProtocolParameters
-> TransactionCtx
-> SelectionOf TxOut
-> Either ErrMkTransaction (Tx, SealedTx)
forall (k :: Depth -> * -> *) tx.
TransactionLayer k tx
-> AnyCardanoEra
-> (XPrv, Passphrase "encryption")
-> (Address -> Maybe (k 'AddressK XPrv, Passphrase "encryption"))
-> ProtocolParameters
-> TransactionCtx
-> SelectionOf TxOut
-> Either ErrMkTransaction (Tx, tx)
mkTransaction TransactionLayer k SealedTx
tl AnyCardanoEra
era (XPrv, Passphrase "encryption")
rewardAcnt Address -> Maybe (k 'AddressK XPrv, Passphrase "encryption")
keyFrom ProtocolParameters
pp TransactionCtx
txCtx SelectionOf TxOut
sel
            (UTCTime
time, TxMeta
meta) <- IO (UTCTime, TxMeta)
-> ExceptT ErrSignPayment stm (UTCTime, TxMeta)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (UTCTime, TxMeta)
 -> ExceptT ErrSignPayment stm (UTCTime, TxMeta))
-> IO (UTCTime, TxMeta)
-> ExceptT ErrSignPayment stm (UTCTime, TxMeta)
forall a b. (a -> b) -> a -> b
$
                TimeInterpreter (ExceptT PastHorizonException IO)
-> BlockHeader
-> s
-> TransactionCtx
-> SelectionOf TxOut
-> IO (UTCTime, TxMeta)
forall s.
IsOurs s Address =>
TimeInterpreter (ExceptT PastHorizonException IO)
-> BlockHeader
-> s
-> TransactionCtx
-> SelectionOf TxOut
-> IO (UTCTime, TxMeta)
mkTxMeta TimeInterpreter (ExceptT PastHorizonException IO)
ti (Wallet s -> BlockHeader
forall s. Wallet s -> BlockHeader
currentTip Wallet s
cp) (Wallet s -> s
forall s. Wallet s -> s
getState Wallet s
cp) TransactionCtx
txCtx SelectionOf TxOut
sel
            (Tx, TxMeta, UTCTime, SealedTx)
-> ExceptT ErrSignPayment stm (Tx, TxMeta, UTCTime, SealedTx)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tx
tx, TxMeta
meta, UTCTime
time, SealedTx
sealedTx)
  where
    db :: DBLayer IO s k
db = ctx
ctx ctx
-> ((DBLayer IO s k -> Const (DBLayer IO s k) (DBLayer IO s k))
    -> ctx -> Const (DBLayer IO s k) ctx)
-> DBLayer IO s k
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx. HasDBLayer IO s k ctx => Lens' ctx (DBLayer IO s k)
forall (m :: * -> *) s (k :: Depth -> * -> *) ctx.
HasDBLayer m s k ctx =>
Lens' ctx (DBLayer m s k)
dbLayer @IO @s @k
    tl :: TransactionLayer k SealedTx
tl = ctx
ctx ctx
-> ((TransactionLayer k SealedTx
     -> Const
          (TransactionLayer k SealedTx) (TransactionLayer k SealedTx))
    -> ctx -> Const (TransactionLayer k SealedTx) ctx)
-> TransactionLayer k SealedTx
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx.
HasTransactionLayer k ctx =>
Lens' ctx (TransactionLayer k SealedTx)
forall (k :: Depth -> * -> *) ctx.
HasTransactionLayer k ctx =>
Lens' ctx (TransactionLayer k SealedTx)
transactionLayer @k
    nl :: NetworkLayer IO Block
nl = ctx
ctx ctx
-> ((NetworkLayer IO Block
     -> Const (NetworkLayer IO Block) (NetworkLayer IO Block))
    -> ctx -> Const (NetworkLayer IO Block) ctx)
-> NetworkLayer IO Block
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. (NetworkLayer IO Block
 -> Const (NetworkLayer IO Block) (NetworkLayer IO Block))
-> ctx -> Const (NetworkLayer IO Block) ctx
forall (m :: * -> *) ctx.
HasNetworkLayer m ctx =>
Lens' ctx (NetworkLayer m Block)
networkLayer
    ti :: TimeInterpreter (ExceptT PastHorizonException IO)
ti = NetworkLayer IO Block
-> TimeInterpreter (ExceptT PastHorizonException IO)
forall (m :: * -> *) block.
NetworkLayer m block
-> TimeInterpreter (ExceptT PastHorizonException m)
timeInterpreter NetworkLayer IO Block
nl


-- | Construct an unsigned transaction from a given selection.
constructTransaction
    :: forall ctx s k (n :: NetworkDiscriminant).
        ( HasTransactionLayer k ctx
        , HasDBLayer IO s k ctx
        , HasNetworkLayer IO ctx
        , Typeable s
        , Typeable n
        )
    => ctx
    -> WalletId
    -> Cardano.AnyCardanoEra
    -> TransactionCtx
    -> SelectionOf TxOut
    -> ExceptT ErrConstructTx IO SealedTx
constructTransaction :: ctx
-> WalletId
-> AnyCardanoEra
-> TransactionCtx
-> SelectionOf TxOut
-> ExceptT ErrConstructTx IO SealedTx
constructTransaction ctx
ctx WalletId
wid AnyCardanoEra
era TransactionCtx
txCtx SelectionOf TxOut
sel = DBLayer IO s k
db DBLayer IO s k
-> (DBLayer IO s k -> ExceptT ErrConstructTx IO SealedTx)
-> ExceptT ErrConstructTx IO SealedTx
forall a b. a -> (a -> b) -> b
& \DBLayer{stm [WalletId]
DBVar stm (DeltaMap WalletId (DeltaWalletState s))
WalletId -> stm [LocalTxSubmissionStatus SealedTx]
WalletId -> stm [ChainPoint]
WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
WalletId -> stm (Maybe GenesisParameters)
WalletId -> stm (Maybe WalletMetadata)
WalletId -> stm (Maybe (Wallet s))
WalletId -> stm Coin
WalletId -> ExceptT ErrNoSuchWallet stm Bool
WalletId -> ExceptT ErrNoSuchWallet stm ()
WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
forall a. stm a -> IO a
atomically :: forall a. stm a -> IO a
prune :: WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
rollbackTo :: WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
readGenesisParameters :: WalletId -> stm (Maybe GenesisParameters)
readPrivateKey :: WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
putPrivateKey :: WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
removePendingOrExpiredTx :: WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
updatePendingTxForExpiry :: WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
readLocalTxSubmissionPending :: WalletId -> stm [LocalTxSubmissionStatus SealedTx]
putLocalTxSubmission :: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
getTx :: WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
readTxHistory :: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
putTxHistory :: WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
readDelegationRewardBalance :: WalletId -> stm Coin
putDelegationRewardBalance :: WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
putDelegationCertificate :: WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
isStakeKeyRegistered :: WalletId -> ExceptT ErrNoSuchWallet stm Bool
readWalletMeta :: WalletId -> stm (Maybe WalletMetadata)
putWalletMeta :: WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
listCheckpoints :: WalletId -> stm [ChainPoint]
readCheckpoint :: WalletId -> stm (Maybe (Wallet s))
putCheckpoint :: WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
walletsDB :: DBVar stm (DeltaMap WalletId (DeltaWalletState s))
listWallets :: stm [WalletId]
removeWallet :: WalletId -> ExceptT ErrNoSuchWallet stm ()
initializeWallet :: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
atomically :: ()
prune :: ()
rollbackTo :: ()
readGenesisParameters :: ()
readPrivateKey :: ()
putPrivateKey :: ()
removePendingOrExpiredTx :: ()
updatePendingTxForExpiry :: ()
readLocalTxSubmissionPending :: ()
putLocalTxSubmission :: ()
getTx :: ()
readTxHistory :: ()
putTxHistory :: ()
readDelegationRewardBalance :: ()
putDelegationRewardBalance :: ()
putDelegationCertificate :: ()
isStakeKeyRegistered :: ()
readWalletMeta :: ()
putWalletMeta :: ()
listCheckpoints :: ()
readCheckpoint :: ()
putCheckpoint :: ()
walletsDB :: ()
listWallets :: ()
removeWallet :: ()
initializeWallet :: ()
..} -> do
    (RewardAccount
_, XPub
xpub, NonEmpty DerivationIndex
_) <- (ErrReadRewardAccount -> ErrConstructTx)
-> ExceptT
     ErrReadRewardAccount
     IO
     (RewardAccount, XPub, NonEmpty DerivationIndex)
-> ExceptT
     ErrConstructTx IO (RewardAccount, XPub, NonEmpty DerivationIndex)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ErrReadRewardAccount -> ErrConstructTx
ErrConstructTxReadRewardAccount (ExceptT
   ErrReadRewardAccount
   IO
   (RewardAccount, XPub, NonEmpty DerivationIndex)
 -> ExceptT
      ErrConstructTx IO (RewardAccount, XPub, NonEmpty DerivationIndex))
-> ExceptT
     ErrReadRewardAccount
     IO
     (RewardAccount, XPub, NonEmpty DerivationIndex)
-> ExceptT
     ErrConstructTx IO (RewardAccount, XPub, NonEmpty DerivationIndex)
forall a b. (a -> b) -> a -> b
$
        ctx
-> WalletId
-> ExceptT
     ErrReadRewardAccount
     IO
     (RewardAccount, XPub, NonEmpty DerivationIndex)
forall ctx s (k :: Depth -> * -> *) (n :: NetworkDiscriminant)
       shelley.
(HasDBLayer IO s k ctx, shelley ~ SeqState n ShelleyKey,
 Typeable n, Typeable s) =>
ctx
-> WalletId
-> ExceptT
     ErrReadRewardAccount
     IO
     (RewardAccount, XPub, NonEmpty DerivationIndex)
readRewardAccount @ctx @s @k @n ctx
ctx WalletId
wid
    (stm (Either ErrConstructTx SealedTx)
 -> IO (Either ErrConstructTx SealedTx))
-> ExceptT ErrConstructTx stm SealedTx
-> ExceptT ErrConstructTx IO SealedTx
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT stm (Either ErrConstructTx SealedTx)
-> IO (Either ErrConstructTx SealedTx)
forall a. stm a -> IO a
atomically (ExceptT ErrConstructTx stm SealedTx
 -> ExceptT ErrConstructTx IO SealedTx)
-> ExceptT ErrConstructTx stm SealedTx
-> ExceptT ErrConstructTx IO SealedTx
forall a b. (a -> b) -> a -> b
$ do
        ProtocolParameters
pp <- IO ProtocolParameters
-> ExceptT ErrConstructTx stm ProtocolParameters
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProtocolParameters
 -> ExceptT ErrConstructTx stm ProtocolParameters)
-> IO ProtocolParameters
-> ExceptT ErrConstructTx stm ProtocolParameters
forall a b. (a -> b) -> a -> b
$ NetworkLayer IO Block -> IO ProtocolParameters
forall (m :: * -> *) block.
NetworkLayer m block -> m ProtocolParameters
currentProtocolParameters NetworkLayer IO Block
nl
        (ErrMkTransaction -> ErrConstructTx)
-> ExceptT ErrMkTransaction stm SealedTx
-> ExceptT ErrConstructTx stm SealedTx
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ErrMkTransaction -> ErrConstructTx
ErrConstructTxBody (ExceptT ErrMkTransaction stm SealedTx
 -> ExceptT ErrConstructTx stm SealedTx)
-> ExceptT ErrMkTransaction stm SealedTx
-> ExceptT ErrConstructTx stm SealedTx
forall a b. (a -> b) -> a -> b
$ stm (Either ErrMkTransaction SealedTx)
-> ExceptT ErrMkTransaction stm SealedTx
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (stm (Either ErrMkTransaction SealedTx)
 -> ExceptT ErrMkTransaction stm SealedTx)
-> stm (Either ErrMkTransaction SealedTx)
-> ExceptT ErrMkTransaction stm SealedTx
forall a b. (a -> b) -> a -> b
$ Either ErrMkTransaction SealedTx
-> stm (Either ErrMkTransaction SealedTx)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrMkTransaction SealedTx
 -> stm (Either ErrMkTransaction SealedTx))
-> Either ErrMkTransaction SealedTx
-> stm (Either ErrMkTransaction SealedTx)
forall a b. (a -> b) -> a -> b
$
            TransactionLayer k SealedTx
-> AnyCardanoEra
-> XPub
-> ProtocolParameters
-> TransactionCtx
-> SelectionOf TxOut
-> Either ErrMkTransaction SealedTx
forall (k :: Depth -> * -> *) tx.
TransactionLayer k tx
-> AnyCardanoEra
-> XPub
-> ProtocolParameters
-> TransactionCtx
-> SelectionOf TxOut
-> Either ErrMkTransaction tx
mkUnsignedTransaction TransactionLayer k SealedTx
tl AnyCardanoEra
era XPub
xpub ProtocolParameters
pp TransactionCtx
txCtx SelectionOf TxOut
sel
  where
    db :: DBLayer IO s k
db = ctx
ctx ctx
-> ((DBLayer IO s k -> Const (DBLayer IO s k) (DBLayer IO s k))
    -> ctx -> Const (DBLayer IO s k) ctx)
-> DBLayer IO s k
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx. HasDBLayer IO s k ctx => Lens' ctx (DBLayer IO s k)
forall (m :: * -> *) s (k :: Depth -> * -> *) ctx.
HasDBLayer m s k ctx =>
Lens' ctx (DBLayer m s k)
dbLayer @IO @s @k
    tl :: TransactionLayer k SealedTx
tl = ctx
ctx ctx
-> ((TransactionLayer k SealedTx
     -> Const
          (TransactionLayer k SealedTx) (TransactionLayer k SealedTx))
    -> ctx -> Const (TransactionLayer k SealedTx) ctx)
-> TransactionLayer k SealedTx
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx.
HasTransactionLayer k ctx =>
Lens' ctx (TransactionLayer k SealedTx)
forall (k :: Depth -> * -> *) ctx.
HasTransactionLayer k ctx =>
Lens' ctx (TransactionLayer k SealedTx)
transactionLayer @k
    nl :: NetworkLayer IO Block
nl = ctx
ctx ctx
-> ((NetworkLayer IO Block
     -> Const (NetworkLayer IO Block) (NetworkLayer IO Block))
    -> ctx -> Const (NetworkLayer IO Block) ctx)
-> NetworkLayer IO Block
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. (NetworkLayer IO Block
 -> Const (NetworkLayer IO Block) (NetworkLayer IO Block))
-> ctx -> Const (NetworkLayer IO Block) ctx
forall (m :: * -> *) ctx.
HasNetworkLayer m ctx =>
Lens' ctx (NetworkLayer m Block)
networkLayer

-- | Construct an unsigned transaction from a given selection
-- for a shared wallet.
constructSharedTransaction
    :: forall ctx s k (n :: NetworkDiscriminant).
        ( HasTransactionLayer k ctx
        , HasDBLayer IO s k ctx
        , HasNetworkLayer IO ctx
        , k ~ SharedKey
        , s ~ SharedState n k
        )
    => ctx
    -> WalletId
    -> Cardano.AnyCardanoEra
    -> TransactionCtx
    -> SelectionOf TxOut
    -> ExceptT ErrConstructTx IO SealedTx
constructSharedTransaction :: ctx
-> WalletId
-> AnyCardanoEra
-> TransactionCtx
-> SelectionOf TxOut
-> ExceptT ErrConstructTx IO SealedTx
constructSharedTransaction ctx
ctx WalletId
wid AnyCardanoEra
era TransactionCtx
txCtx SelectionOf TxOut
sel = DBLayer IO s k
db DBLayer IO s k
-> (DBLayer IO s k -> ExceptT ErrConstructTx IO SealedTx)
-> ExceptT ErrConstructTx IO SealedTx
forall a b. a -> (a -> b) -> b
& \DBLayer{stm [WalletId]
DBVar stm (DeltaMap WalletId (DeltaWalletState s))
WalletId -> stm [LocalTxSubmissionStatus SealedTx]
WalletId -> stm [ChainPoint]
WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
WalletId -> stm (Maybe GenesisParameters)
WalletId -> stm (Maybe WalletMetadata)
WalletId -> stm (Maybe (Wallet s))
WalletId -> stm Coin
WalletId -> ExceptT ErrNoSuchWallet stm Bool
WalletId -> ExceptT ErrNoSuchWallet stm ()
WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
forall a. stm a -> IO a
atomically :: forall a. stm a -> IO a
prune :: WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
rollbackTo :: WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
readGenesisParameters :: WalletId -> stm (Maybe GenesisParameters)
readPrivateKey :: WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
putPrivateKey :: WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
removePendingOrExpiredTx :: WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
updatePendingTxForExpiry :: WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
readLocalTxSubmissionPending :: WalletId -> stm [LocalTxSubmissionStatus SealedTx]
putLocalTxSubmission :: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
getTx :: WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
readTxHistory :: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
putTxHistory :: WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
readDelegationRewardBalance :: WalletId -> stm Coin
putDelegationRewardBalance :: WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
putDelegationCertificate :: WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
isStakeKeyRegistered :: WalletId -> ExceptT ErrNoSuchWallet stm Bool
readWalletMeta :: WalletId -> stm (Maybe WalletMetadata)
putWalletMeta :: WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
listCheckpoints :: WalletId -> stm [ChainPoint]
readCheckpoint :: WalletId -> stm (Maybe (Wallet s))
putCheckpoint :: WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
walletsDB :: DBVar stm (DeltaMap WalletId (DeltaWalletState s))
listWallets :: stm [WalletId]
removeWallet :: WalletId -> ExceptT ErrNoSuchWallet stm ()
initializeWallet :: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
atomically :: ()
prune :: ()
rollbackTo :: ()
readGenesisParameters :: ()
readPrivateKey :: ()
putPrivateKey :: ()
removePendingOrExpiredTx :: ()
updatePendingTxForExpiry :: ()
readLocalTxSubmissionPending :: ()
putLocalTxSubmission :: ()
getTx :: ()
readTxHistory :: ()
putTxHistory :: ()
readDelegationRewardBalance :: ()
putDelegationRewardBalance :: ()
putDelegationCertificate :: ()
isStakeKeyRegistered :: ()
readWalletMeta :: ()
putWalletMeta :: ()
listCheckpoints :: ()
readCheckpoint :: ()
putCheckpoint :: ()
walletsDB :: ()
listWallets :: ()
removeWallet :: ()
initializeWallet :: ()
..} -> do
    Wallet s
cp <- (ErrNoSuchWallet -> ErrConstructTx)
-> ExceptT ErrNoSuchWallet IO (Wallet s)
-> ExceptT ErrConstructTx IO (Wallet s)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ErrNoSuchWallet -> ErrConstructTx
ErrConstructTxNoSuchWallet
        (ExceptT ErrNoSuchWallet IO (Wallet s)
 -> ExceptT ErrConstructTx IO (Wallet s))
-> ExceptT ErrNoSuchWallet IO (Wallet s)
-> ExceptT ErrConstructTx IO (Wallet s)
forall a b. (a -> b) -> a -> b
$ (stm (Either ErrNoSuchWallet (Wallet s))
 -> IO (Either ErrNoSuchWallet (Wallet s)))
-> ExceptT ErrNoSuchWallet stm (Wallet s)
-> ExceptT ErrNoSuchWallet IO (Wallet s)
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT stm (Either ErrNoSuchWallet (Wallet s))
-> IO (Either ErrNoSuchWallet (Wallet s))
forall a. stm a -> IO a
atomically
        (ExceptT ErrNoSuchWallet stm (Wallet s)
 -> ExceptT ErrNoSuchWallet IO (Wallet s))
-> ExceptT ErrNoSuchWallet stm (Wallet s)
-> ExceptT ErrNoSuchWallet IO (Wallet s)
forall a b. (a -> b) -> a -> b
$ WalletId
-> stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s)
forall (m :: * -> *) a.
Monad m =>
WalletId -> m (Maybe a) -> ExceptT ErrNoSuchWallet m a
withNoSuchWallet WalletId
wid
        (stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s))
-> stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s)
forall a b. (a -> b) -> a -> b
$ WalletId -> stm (Maybe (Wallet s))
readCheckpoint WalletId
wid
    let s :: s
s = Wallet s -> s
forall s. Wallet s -> s
getState Wallet s
cp
    let accXPub :: XPub
accXPub = SharedKey 'AccountK XPub -> XPub
forall (key :: Depth -> * -> *) (depth :: Depth) raw.
WalletKey key =>
key depth raw -> raw
getRawKey (SharedKey 'AccountK XPub -> XPub)
-> SharedKey 'AccountK XPub -> XPub
forall a b. (a -> b) -> a -> b
$ SharedState n SharedKey -> SharedKey 'AccountK XPub
forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
SharedState n k -> k 'AccountK XPub
Shared.accountXPub s
SharedState n SharedKey
s
    let xpub :: XPub
xpub = Shared 'ScriptK XPub -> XPub
forall (depth :: Depth) key. Shared depth key -> key
CA.getKey (Shared 'ScriptK XPub -> XPub) -> Shared 'ScriptK XPub -> XPub
forall a b. (a -> b) -> a -> b
$
            Shared 'AccountK XPub
-> Index 'Soft 'PaymentK -> Shared 'ScriptK XPub
deriveDelegationPublicKey (XPub -> Shared 'AccountK XPub
forall (depth :: Depth). XPub -> Shared depth XPub
CA.liftXPub XPub
accXPub) Index 'Soft 'PaymentK
forall a. Bounded a => a
minBound
    (stm (Either ErrConstructTx SealedTx)
 -> IO (Either ErrConstructTx SealedTx))
-> ExceptT ErrConstructTx stm SealedTx
-> ExceptT ErrConstructTx IO SealedTx
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT stm (Either ErrConstructTx SealedTx)
-> IO (Either ErrConstructTx SealedTx)
forall a. stm a -> IO a
atomically (ExceptT ErrConstructTx stm SealedTx
 -> ExceptT ErrConstructTx IO SealedTx)
-> ExceptT ErrConstructTx stm SealedTx
-> ExceptT ErrConstructTx IO SealedTx
forall a b. (a -> b) -> a -> b
$ do
        ProtocolParameters
pp <- IO ProtocolParameters
-> ExceptT ErrConstructTx stm ProtocolParameters
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProtocolParameters
 -> ExceptT ErrConstructTx stm ProtocolParameters)
-> IO ProtocolParameters
-> ExceptT ErrConstructTx stm ProtocolParameters
forall a b. (a -> b) -> a -> b
$ NetworkLayer IO Block -> IO ProtocolParameters
forall (m :: * -> *) block.
NetworkLayer m block -> m ProtocolParameters
currentProtocolParameters NetworkLayer IO Block
nl
        (ErrMkTransaction -> ErrConstructTx)
-> ExceptT ErrMkTransaction stm SealedTx
-> ExceptT ErrConstructTx stm SealedTx
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ErrMkTransaction -> ErrConstructTx
ErrConstructTxBody (ExceptT ErrMkTransaction stm SealedTx
 -> ExceptT ErrConstructTx stm SealedTx)
-> ExceptT ErrMkTransaction stm SealedTx
-> ExceptT ErrConstructTx stm SealedTx
forall a b. (a -> b) -> a -> b
$ stm (Either ErrMkTransaction SealedTx)
-> ExceptT ErrMkTransaction stm SealedTx
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (stm (Either ErrMkTransaction SealedTx)
 -> ExceptT ErrMkTransaction stm SealedTx)
-> stm (Either ErrMkTransaction SealedTx)
-> ExceptT ErrMkTransaction stm SealedTx
forall a b. (a -> b) -> a -> b
$ Either ErrMkTransaction SealedTx
-> stm (Either ErrMkTransaction SealedTx)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrMkTransaction SealedTx
 -> stm (Either ErrMkTransaction SealedTx))
-> Either ErrMkTransaction SealedTx
-> stm (Either ErrMkTransaction SealedTx)
forall a b. (a -> b) -> a -> b
$
            TransactionLayer k SealedTx
-> AnyCardanoEra
-> XPub
-> ProtocolParameters
-> TransactionCtx
-> SelectionOf TxOut
-> Either ErrMkTransaction SealedTx
forall (k :: Depth -> * -> *) tx.
TransactionLayer k tx
-> AnyCardanoEra
-> XPub
-> ProtocolParameters
-> TransactionCtx
-> SelectionOf TxOut
-> Either ErrMkTransaction tx
mkUnsignedTransaction TransactionLayer k SealedTx
tl AnyCardanoEra
era XPub
xpub ProtocolParameters
pp TransactionCtx
txCtx SelectionOf TxOut
sel
  where
    db :: DBLayer IO s k
db = ctx
ctx ctx
-> ((DBLayer IO s k -> Const (DBLayer IO s k) (DBLayer IO s k))
    -> ctx -> Const (DBLayer IO s k) ctx)
-> DBLayer IO s k
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx. HasDBLayer IO s k ctx => Lens' ctx (DBLayer IO s k)
forall (m :: * -> *) s (k :: Depth -> * -> *) ctx.
HasDBLayer m s k ctx =>
Lens' ctx (DBLayer m s k)
dbLayer @IO @s @k
    tl :: TransactionLayer k SealedTx
tl = ctx
ctx ctx
-> ((TransactionLayer k SealedTx
     -> Const
          (TransactionLayer k SealedTx) (TransactionLayer k SealedTx))
    -> ctx -> Const (TransactionLayer k SealedTx) ctx)
-> TransactionLayer k SealedTx
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx.
HasTransactionLayer k ctx =>
Lens' ctx (TransactionLayer k SealedTx)
forall (k :: Depth -> * -> *) ctx.
HasTransactionLayer k ctx =>
Lens' ctx (TransactionLayer k SealedTx)
transactionLayer @k
    nl :: NetworkLayer IO Block
nl = ctx
ctx ctx
-> ((NetworkLayer IO Block
     -> Const (NetworkLayer IO Block) (NetworkLayer IO Block))
    -> ctx -> Const (NetworkLayer IO Block) ctx)
-> NetworkLayer IO Block
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. (NetworkLayer IO Block
 -> Const (NetworkLayer IO Block) (NetworkLayer IO Block))
-> ctx -> Const (NetworkLayer IO Block) ctx
forall (m :: * -> *) ctx.
HasNetworkLayer m ctx =>
Lens' ctx (NetworkLayer m Block)
networkLayer

-- | Calculate the transaction expiry slot, given a 'TimeInterpreter', and an
-- optional TTL in seconds.
--
-- If no TTL is provided, a default of 2 hours is used (note: there is no
-- particular reason why we chose that duration).
getTxExpiry
    :: TimeInterpreter (ExceptT PastHorizonException IO)
    -- ^ Context for time to slot calculation.
    -> Maybe NominalDiffTime
    -- ^ Time to live (TTL) in seconds from now.
    -> IO SlotNo
getTxExpiry :: TimeInterpreter (ExceptT PastHorizonException IO)
-> Maybe NominalDiffTime -> IO SlotNo
getTxExpiry TimeInterpreter (ExceptT PastHorizonException IO)
ti Maybe NominalDiffTime
maybeTTL = do
    RelativeTime
expTime <- NominalDiffTime -> RelativeTime -> RelativeTime
addRelTime NominalDiffTime
ttl (RelativeTime -> RelativeTime)
-> IO RelativeTime -> IO RelativeTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TimeInterpreter IO -> IO RelativeTime
forall (m :: * -> *) (n :: * -> *).
MonadIO m =>
TimeInterpreter n -> m RelativeTime
currentRelativeTime (TimeInterpreter (ExceptT PastHorizonException IO)
-> TimeInterpreter IO
unsafeExtendSafeZone TimeInterpreter (ExceptT PastHorizonException IO)
ti)
    TimeInterpreter IO -> Qry SlotNo -> IO SlotNo
forall (m :: * -> *) a.
(HasCallStack, Monad m) =>
TimeInterpreter m -> Qry a -> m a
interpretQuery (TimeInterpreter (ExceptT PastHorizonException IO)
-> TimeInterpreter IO
unsafeExtendSafeZone TimeInterpreter (ExceptT PastHorizonException IO)
ti) (Qry SlotNo -> IO SlotNo) -> Qry SlotNo -> IO SlotNo
forall a b. (a -> b) -> a -> b
$ RelativeTime -> Qry SlotNo
ceilingSlotAt RelativeTime
expTime
  where
    ttl :: NominalDiffTime
ttl = NominalDiffTime -> Maybe NominalDiffTime -> NominalDiffTime
forall a. a -> Maybe a -> a
fromMaybe NominalDiffTime
defaultTTL Maybe NominalDiffTime
maybeTTL

    defaultTTL :: NominalDiffTime
    defaultTTL :: NominalDiffTime
defaultTTL = NominalDiffTime
7200  -- that's 2 hours

constructTxMeta
    :: forall ctx s k.
        ( HasDBLayer IO s k ctx
        )
    => ctx
    -> WalletId
    -> TransactionCtx
    -> [(TxIn, Coin)]
    -> [TxOut]
    -> ExceptT ErrSubmitTransaction IO TxMeta
constructTxMeta :: ctx
-> WalletId
-> TransactionCtx
-> [(TxIn, Coin)]
-> [TxOut]
-> ExceptT ErrSubmitTransaction IO TxMeta
constructTxMeta ctx
ctx WalletId
wid TransactionCtx
txCtx [(TxIn, Coin)]
inps [TxOut]
outs = DBLayer IO s k
db DBLayer IO s k
-> (DBLayer IO s k -> ExceptT ErrSubmitTransaction IO TxMeta)
-> ExceptT ErrSubmitTransaction IO TxMeta
forall a b. a -> (a -> b) -> b
& \DBLayer{stm [WalletId]
DBVar stm (DeltaMap WalletId (DeltaWalletState s))
WalletId -> stm [LocalTxSubmissionStatus SealedTx]
WalletId -> stm [ChainPoint]
WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
WalletId -> stm (Maybe GenesisParameters)
WalletId -> stm (Maybe WalletMetadata)
WalletId -> stm (Maybe (Wallet s))
WalletId -> stm Coin
WalletId -> ExceptT ErrNoSuchWallet stm Bool
WalletId -> ExceptT ErrNoSuchWallet stm ()
WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
forall a. stm a -> IO a
atomically :: forall a. stm a -> IO a
prune :: WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
rollbackTo :: WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
readGenesisParameters :: WalletId -> stm (Maybe GenesisParameters)
readPrivateKey :: WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
putPrivateKey :: WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
removePendingOrExpiredTx :: WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
updatePendingTxForExpiry :: WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
readLocalTxSubmissionPending :: WalletId -> stm [LocalTxSubmissionStatus SealedTx]
putLocalTxSubmission :: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
getTx :: WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
readTxHistory :: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
putTxHistory :: WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
readDelegationRewardBalance :: WalletId -> stm Coin
putDelegationRewardBalance :: WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
putDelegationCertificate :: WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
isStakeKeyRegistered :: WalletId -> ExceptT ErrNoSuchWallet stm Bool
readWalletMeta :: WalletId -> stm (Maybe WalletMetadata)
putWalletMeta :: WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
listCheckpoints :: WalletId -> stm [ChainPoint]
readCheckpoint :: WalletId -> stm (Maybe (Wallet s))
putCheckpoint :: WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
walletsDB :: DBVar stm (DeltaMap WalletId (DeltaWalletState s))
listWallets :: stm [WalletId]
removeWallet :: WalletId -> ExceptT ErrNoSuchWallet stm ()
initializeWallet :: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
atomically :: ()
prune :: ()
rollbackTo :: ()
readGenesisParameters :: ()
readPrivateKey :: ()
putPrivateKey :: ()
removePendingOrExpiredTx :: ()
updatePendingTxForExpiry :: ()
readLocalTxSubmissionPending :: ()
putLocalTxSubmission :: ()
getTx :: ()
readTxHistory :: ()
putTxHistory :: ()
readDelegationRewardBalance :: ()
putDelegationRewardBalance :: ()
putDelegationCertificate :: ()
isStakeKeyRegistered :: ()
readWalletMeta :: ()
putWalletMeta :: ()
listCheckpoints :: ()
readCheckpoint :: ()
putCheckpoint :: ()
walletsDB :: ()
listWallets :: ()
removeWallet :: ()
initializeWallet :: ()
..} -> do
    (stm (Either ErrSubmitTransaction TxMeta)
 -> IO (Either ErrSubmitTransaction TxMeta))
-> ExceptT ErrSubmitTransaction stm TxMeta
-> ExceptT ErrSubmitTransaction IO TxMeta
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT stm (Either ErrSubmitTransaction TxMeta)
-> IO (Either ErrSubmitTransaction TxMeta)
forall a. stm a -> IO a
atomically (ExceptT ErrSubmitTransaction stm TxMeta
 -> ExceptT ErrSubmitTransaction IO TxMeta)
-> ExceptT ErrSubmitTransaction stm TxMeta
-> ExceptT ErrSubmitTransaction IO TxMeta
forall a b. (a -> b) -> a -> b
$ do
        Wallet s
cp <- (ErrNoSuchWallet -> ErrSubmitTransaction)
-> ExceptT ErrNoSuchWallet stm (Wallet s)
-> ExceptT ErrSubmitTransaction stm (Wallet s)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ErrNoSuchWallet -> ErrSubmitTransaction
ErrSubmitTransactionNoSuchWallet
              (ExceptT ErrNoSuchWallet stm (Wallet s)
 -> ExceptT ErrSubmitTransaction stm (Wallet s))
-> ExceptT ErrNoSuchWallet stm (Wallet s)
-> ExceptT ErrSubmitTransaction stm (Wallet s)
forall a b. (a -> b) -> a -> b
$ WalletId
-> stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s)
forall (m :: * -> *) a.
Monad m =>
WalletId -> m (Maybe a) -> ExceptT ErrNoSuchWallet m a
withNoSuchWallet WalletId
wid
              (stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s))
-> stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s)
forall a b. (a -> b) -> a -> b
$ WalletId -> stm (Maybe (Wallet s))
readCheckpoint WalletId
wid
        IO TxMeta -> ExceptT ErrSubmitTransaction stm TxMeta
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO TxMeta -> ExceptT ErrSubmitTransaction stm TxMeta)
-> IO TxMeta -> ExceptT ErrSubmitTransaction stm TxMeta
forall a b. (a -> b) -> a -> b
$
            BlockHeader
-> TransactionCtx -> [(TxIn, Coin)] -> [TxOut] -> IO TxMeta
mkTxMetaWithoutSel (Wallet s -> BlockHeader
forall s. Wallet s -> BlockHeader
currentTip Wallet s
cp) TransactionCtx
txCtx [(TxIn, Coin)]
inps [TxOut]
outs
  where
    db :: DBLayer IO s k
db = ctx
ctx ctx
-> ((DBLayer IO s k -> Const (DBLayer IO s k) (DBLayer IO s k))
    -> ctx -> Const (DBLayer IO s k) ctx)
-> DBLayer IO s k
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx. HasDBLayer IO s k ctx => Lens' ctx (DBLayer IO s k)
forall (m :: * -> *) s (k :: Depth -> * -> *) ctx.
HasDBLayer m s k ctx =>
Lens' ctx (DBLayer m s k)
dbLayer @IO @s @k

mkTxMetaWithoutSel
    :: BlockHeader
    -> TransactionCtx
    -> [(TxIn, Coin)]
    -> [TxOut]
    -> IO TxMeta
mkTxMetaWithoutSel :: BlockHeader
-> TransactionCtx -> [(TxIn, Coin)] -> [TxOut] -> IO TxMeta
mkTxMetaWithoutSel BlockHeader
blockHeader TransactionCtx
txCtx [(TxIn, Coin)]
inps [TxOut]
outs =
    let
        amtOuts :: Coin
amtOuts = [Coin] -> Coin
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
F.fold ([Coin] -> Coin) -> [Coin] -> Coin
forall a b. (a -> b) -> a -> b
$ (TxOut -> Coin) -> [TxOut] -> [Coin]
forall a b. (a -> b) -> [a] -> [b]
map TxOut -> Coin
txOutCoin [TxOut]
outs

        amtInps :: Coin
amtInps
            = [Coin] -> Coin
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
F.fold (((TxIn, Coin) -> Coin) -> [(TxIn, Coin)] -> [Coin]
forall a b. (a -> b) -> [a] -> [b]
map (TxIn, Coin) -> Coin
forall a b. (a, b) -> b
snd [(TxIn, Coin)]
inps)
            Coin -> (Coin -> Coin) -> Coin
forall a b. a -> (a -> b) -> b
& case TransactionCtx -> Withdrawal
txWithdrawal TransactionCtx
txCtx of
                w :: Withdrawal
w@WithdrawalSelf{} -> Coin -> Coin -> Coin
Coin.add (Withdrawal -> Coin
withdrawalToCoin Withdrawal
w)
                WithdrawalExternal{} -> Coin -> Coin
forall a. a -> a
Prelude.id
                Withdrawal
NoWithdrawal -> Coin -> Coin
forall a. a -> a
Prelude.id
    in TxMeta -> IO TxMeta
forall (m :: * -> *) a. Monad m => a -> m a
return TxMeta :: TxStatus
-> Direction
-> SlotNo
-> Quantity "block" Word32
-> Coin
-> Maybe SlotNo
-> TxMeta
TxMeta
       { $sel:status:TxMeta :: TxStatus
status = TxStatus
Pending
       , $sel:direction:TxMeta :: Direction
direction = if Coin
amtInps Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
> Coin
amtOuts then Direction
Outgoing else Direction
Incoming
       , $sel:slotNo:TxMeta :: SlotNo
slotNo = BlockHeader
blockHeader BlockHeader
-> ((SlotNo -> Const SlotNo SlotNo)
    -> BlockHeader -> Const SlotNo BlockHeader)
-> SlotNo
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "slotNo"
  ((SlotNo -> Const SlotNo SlotNo)
   -> BlockHeader -> Const SlotNo BlockHeader)
(SlotNo -> Const SlotNo SlotNo)
-> BlockHeader -> Const SlotNo BlockHeader
#slotNo
       , $sel:blockHeight:TxMeta :: Quantity "block" Word32
blockHeight = BlockHeader
blockHeader BlockHeader
-> ((Quantity "block" Word32
     -> Const (Quantity "block" Word32) (Quantity "block" Word32))
    -> BlockHeader -> Const (Quantity "block" Word32) BlockHeader)
-> Quantity "block" Word32
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "blockHeight"
  ((Quantity "block" Word32
    -> Const (Quantity "block" Word32) (Quantity "block" Word32))
   -> BlockHeader -> Const (Quantity "block" Word32) BlockHeader)
(Quantity "block" Word32
 -> Const (Quantity "block" Word32) (Quantity "block" Word32))
-> BlockHeader -> Const (Quantity "block" Word32) BlockHeader
#blockHeight
       , $sel:amount:TxMeta :: Coin
amount = Coin -> Coin -> Coin
Coin.distance Coin
amtInps Coin
amtOuts
       , $sel:expiry:TxMeta :: Maybe SlotNo
expiry = SlotNo -> Maybe SlotNo
forall a. a -> Maybe a
Just ((Maybe SlotNo, SlotNo) -> SlotNo
forall a b. (a, b) -> b
snd ((Maybe SlotNo, SlotNo) -> SlotNo)
-> (Maybe SlotNo, SlotNo) -> SlotNo
forall a b. (a -> b) -> a -> b
$ TransactionCtx -> (Maybe SlotNo, SlotNo)
txValidityInterval TransactionCtx
txCtx)
       }

ourCoin
    :: IsOurs s Address
    => TxOut
    -> s
    -> Maybe Coin
ourCoin :: TxOut -> s -> Maybe Coin
ourCoin (TxOut Address
addr TokenBundle
tokens) s
wState =
    case (Maybe (NonEmpty DerivationIndex), s)
-> Maybe (NonEmpty DerivationIndex)
forall a b. (a, b) -> a
fst (Address -> s -> (Maybe (NonEmpty DerivationIndex), s)
forall s entity.
IsOurs s entity =>
entity -> s -> (Maybe (NonEmpty DerivationIndex), s)
isOurs Address
addr s
wState) of
        Just{}  -> Coin -> Maybe Coin
forall a. a -> Maybe a
Just (TokenBundle -> Coin
TokenBundle.getCoin TokenBundle
tokens)
        Maybe (NonEmpty DerivationIndex)
Nothing -> Maybe Coin
forall a. Maybe a
Nothing

-- | Construct transaction metadata for a pending transaction from the block
-- header of the current tip and a list of input and output.
--
-- FIXME: There's a logic duplication regarding the calculation of the transaction
-- amount between right here, and the Primitive.Model (see prefilterBlocks).
mkTxMeta
    :: IsOurs s Address
    => TimeInterpreter (ExceptT PastHorizonException IO)
    -> BlockHeader
    -> s
    -> TransactionCtx
    -> SelectionOf TxOut
    -> IO (UTCTime, TxMeta)
mkTxMeta :: TimeInterpreter (ExceptT PastHorizonException IO)
-> BlockHeader
-> s
-> TransactionCtx
-> SelectionOf TxOut
-> IO (UTCTime, TxMeta)
mkTxMeta TimeInterpreter (ExceptT PastHorizonException IO)
ti' BlockHeader
blockHeader s
wState TransactionCtx
txCtx SelectionOf TxOut
sel =
    let
        amtOuts :: Coin
amtOuts = [Coin] -> Coin
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
F.fold ([Coin] -> Coin) -> [Coin] -> Coin
forall a b. (a -> b) -> a -> b
$
            (TxOut -> Coin
txOutCoin (TxOut -> Coin) -> [TxOut] -> [Coin]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (([TxOut] -> Const [TxOut] [TxOut])
 -> SelectionOf TxOut -> Const [TxOut] (SelectionOf TxOut))
-> SelectionOf TxOut -> [TxOut]
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "change"
  (([TxOut] -> Const [TxOut] [TxOut])
   -> SelectionOf TxOut -> Const [TxOut] (SelectionOf TxOut))
([TxOut] -> Const [TxOut] [TxOut])
-> SelectionOf TxOut -> Const [TxOut] (SelectionOf TxOut)
#change SelectionOf TxOut
sel)
            [Coin] -> [Coin] -> [Coin]
forall a. [a] -> [a] -> [a]
++
            (TxOut -> Maybe Coin) -> [TxOut] -> [Coin]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (TxOut -> s -> Maybe Coin
forall s. IsOurs s Address => TxOut -> s -> Maybe Coin
`ourCoin` s
wState) ((([TxOut] -> Const [TxOut] [TxOut])
 -> SelectionOf TxOut -> Const [TxOut] (SelectionOf TxOut))
-> SelectionOf TxOut -> [TxOut]
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "outputs"
  (([TxOut] -> Const [TxOut] [TxOut])
   -> SelectionOf TxOut -> Const [TxOut] (SelectionOf TxOut))
([TxOut] -> Const [TxOut] [TxOut])
-> SelectionOf TxOut -> Const [TxOut] (SelectionOf TxOut)
#outputs SelectionOf TxOut
sel)

        amtInps :: Coin
amtInps
            = NonEmpty Coin -> Coin
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
F.fold (TxOut -> Coin
txOutCoin (TxOut -> Coin)
-> ((TxIn, TxOut) -> TxOut) -> (TxIn, TxOut) -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn, TxOut) -> TxOut
forall a b. (a, b) -> b
snd ((TxIn, TxOut) -> Coin) -> NonEmpty (TxIn, TxOut) -> NonEmpty Coin
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((NonEmpty (TxIn, TxOut)
  -> Const (NonEmpty (TxIn, TxOut)) (NonEmpty (TxIn, TxOut)))
 -> SelectionOf TxOut
 -> Const (NonEmpty (TxIn, TxOut)) (SelectionOf TxOut))
-> SelectionOf TxOut -> NonEmpty (TxIn, TxOut)
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "inputs"
  ((NonEmpty (TxIn, TxOut)
    -> Const (NonEmpty (TxIn, TxOut)) (NonEmpty (TxIn, TxOut)))
   -> SelectionOf TxOut
   -> Const (NonEmpty (TxIn, TxOut)) (SelectionOf TxOut))
(NonEmpty (TxIn, TxOut)
 -> Const (NonEmpty (TxIn, TxOut)) (NonEmpty (TxIn, TxOut)))
-> SelectionOf TxOut
-> Const (NonEmpty (TxIn, TxOut)) (SelectionOf TxOut)
#inputs SelectionOf TxOut
sel)
            -- NOTE: In case where rewards were pulled from an external
            -- source, they aren't added to the calculation because the
            -- money is considered to come from outside of the wallet; which
            -- changes the way we look at transactions (in such case, a
            -- transaction is considered 'Incoming' since it brings extra money
            -- to the wallet from elsewhere).
            Coin -> (Coin -> Coin) -> Coin
forall a b. a -> (a -> b) -> b
& case TransactionCtx -> Withdrawal
txWithdrawal TransactionCtx
txCtx of
                w :: Withdrawal
w@WithdrawalSelf{} -> Coin -> Coin -> Coin
Coin.add (Withdrawal -> Coin
withdrawalToCoin Withdrawal
w)
                WithdrawalExternal{} -> Coin -> Coin
forall a. a -> a
Prelude.id
                Withdrawal
NoWithdrawal -> Coin -> Coin
forall a. a -> a
Prelude.id
    in do
        UTCTime
t <- SlotNo -> IO UTCTime
slotStartTime' (BlockHeader
blockHeader BlockHeader
-> ((SlotNo -> Const SlotNo SlotNo)
    -> BlockHeader -> Const SlotNo BlockHeader)
-> SlotNo
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "slotNo"
  ((SlotNo -> Const SlotNo SlotNo)
   -> BlockHeader -> Const SlotNo BlockHeader)
(SlotNo -> Const SlotNo SlotNo)
-> BlockHeader -> Const SlotNo BlockHeader
#slotNo)
        (UTCTime, TxMeta) -> IO (UTCTime, TxMeta)
forall (m :: * -> *) a. Monad m => a -> m a
return
            ( UTCTime
t
            , TxMeta :: TxStatus
-> Direction
-> SlotNo
-> Quantity "block" Word32
-> Coin
-> Maybe SlotNo
-> TxMeta
TxMeta
                { $sel:status:TxMeta :: TxStatus
status = TxStatus
Pending
                , $sel:direction:TxMeta :: Direction
direction = if Coin
amtInps Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
> Coin
amtOuts then Direction
Outgoing else Direction
Incoming
                , $sel:slotNo:TxMeta :: SlotNo
slotNo = BlockHeader
blockHeader BlockHeader
-> ((SlotNo -> Const SlotNo SlotNo)
    -> BlockHeader -> Const SlotNo BlockHeader)
-> SlotNo
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "slotNo"
  ((SlotNo -> Const SlotNo SlotNo)
   -> BlockHeader -> Const SlotNo BlockHeader)
(SlotNo -> Const SlotNo SlotNo)
-> BlockHeader -> Const SlotNo BlockHeader
#slotNo
                , $sel:blockHeight:TxMeta :: Quantity "block" Word32
blockHeight = BlockHeader
blockHeader BlockHeader
-> ((Quantity "block" Word32
     -> Const (Quantity "block" Word32) (Quantity "block" Word32))
    -> BlockHeader -> Const (Quantity "block" Word32) BlockHeader)
-> Quantity "block" Word32
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "blockHeight"
  ((Quantity "block" Word32
    -> Const (Quantity "block" Word32) (Quantity "block" Word32))
   -> BlockHeader -> Const (Quantity "block" Word32) BlockHeader)
(Quantity "block" Word32
 -> Const (Quantity "block" Word32) (Quantity "block" Word32))
-> BlockHeader -> Const (Quantity "block" Word32) BlockHeader
#blockHeight
                , $sel:amount:TxMeta :: Coin
amount = Coin -> Coin -> Coin
Coin.distance Coin
amtInps Coin
amtOuts
                , $sel:expiry:TxMeta :: Maybe SlotNo
expiry = SlotNo -> Maybe SlotNo
forall a. a -> Maybe a
Just ((Maybe SlotNo, SlotNo) -> SlotNo
forall a b. (a, b) -> b
snd ((Maybe SlotNo, SlotNo) -> SlotNo)
-> (Maybe SlotNo, SlotNo) -> SlotNo
forall a b. (a -> b) -> a -> b
$ TransactionCtx -> (Maybe SlotNo, SlotNo)
txValidityInterval TransactionCtx
txCtx)
                }
            )
  where
    slotStartTime' :: SlotNo -> IO UTCTime
slotStartTime' = TimeInterpreter IO -> Qry UTCTime -> IO UTCTime
forall (m :: * -> *) a.
(HasCallStack, Monad m) =>
TimeInterpreter m -> Qry a -> m a
interpretQuery TimeInterpreter IO
ti (Qry UTCTime -> IO UTCTime)
-> (SlotNo -> Qry UTCTime) -> SlotNo -> IO UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlotNo -> Qry UTCTime
slotToUTCTime
      where
        ti :: TimeInterpreter IO
ti = String
-> TimeInterpreter (ExceptT PastHorizonException IO)
-> TimeInterpreter IO
neverFails String
"mkTxMeta slots should never be ahead of the node tip" TimeInterpreter (ExceptT PastHorizonException IO)
ti'

-- | Broadcast a (signed) transaction to the network.
submitTx
    :: forall ctx s k.
        ( HasNetworkLayer IO ctx
        , HasDBLayer IO s k ctx
        , HasLogger IO WalletWorkerLog ctx
        )
    => ctx
    -> WalletId
    -> (Tx, TxMeta, SealedTx)
    -> ExceptT ErrSubmitTx IO ()
submitTx :: ctx
-> WalletId -> (Tx, TxMeta, SealedTx) -> ExceptT ErrSubmitTx IO ()
submitTx ctx
ctx WalletId
wid (Tx
tx, TxMeta
meta, SealedTx
binary) = Tracer IO (BracketLog' (Either ErrSubmitTx ()))
-> ExceptT ErrSubmitTx IO () -> ExceptT ErrSubmitTx IO ()
forall (m :: * -> *) e r.
MonadUnliftIO m =>
Tracer m (BracketLog' (Either e r))
-> ExceptT e m r -> ExceptT e m r
traceResult Tracer IO (BracketLog' (Either ErrSubmitTx ()))
tr' (ExceptT ErrSubmitTx IO () -> ExceptT ErrSubmitTx IO ())
-> ExceptT ErrSubmitTx IO () -> ExceptT ErrSubmitTx IO ()
forall a b. (a -> b) -> a -> b
$ DBLayer IO s k
db DBLayer IO s k
-> (DBLayer IO s k -> ExceptT ErrSubmitTx IO ())
-> ExceptT ErrSubmitTx IO ()
forall a b. a -> (a -> b) -> b
& \DBLayer{stm [WalletId]
DBVar stm (DeltaMap WalletId (DeltaWalletState s))
WalletId -> stm [LocalTxSubmissionStatus SealedTx]
WalletId -> stm [ChainPoint]
WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
WalletId -> stm (Maybe GenesisParameters)
WalletId -> stm (Maybe WalletMetadata)
WalletId -> stm (Maybe (Wallet s))
WalletId -> stm Coin
WalletId -> ExceptT ErrNoSuchWallet stm Bool
WalletId -> ExceptT ErrNoSuchWallet stm ()
WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
forall a. stm a -> IO a
atomically :: forall a. stm a -> IO a
prune :: WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
rollbackTo :: WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
readGenesisParameters :: WalletId -> stm (Maybe GenesisParameters)
readPrivateKey :: WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
putPrivateKey :: WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
removePendingOrExpiredTx :: WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
updatePendingTxForExpiry :: WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
readLocalTxSubmissionPending :: WalletId -> stm [LocalTxSubmissionStatus SealedTx]
putLocalTxSubmission :: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
getTx :: WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
readTxHistory :: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
putTxHistory :: WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
readDelegationRewardBalance :: WalletId -> stm Coin
putDelegationRewardBalance :: WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
putDelegationCertificate :: WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
isStakeKeyRegistered :: WalletId -> ExceptT ErrNoSuchWallet stm Bool
readWalletMeta :: WalletId -> stm (Maybe WalletMetadata)
putWalletMeta :: WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
listCheckpoints :: WalletId -> stm [ChainPoint]
readCheckpoint :: WalletId -> stm (Maybe (Wallet s))
putCheckpoint :: WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
walletsDB :: DBVar stm (DeltaMap WalletId (DeltaWalletState s))
listWallets :: stm [WalletId]
removeWallet :: WalletId -> ExceptT ErrNoSuchWallet stm ()
initializeWallet :: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
atomically :: ()
prune :: ()
rollbackTo :: ()
readGenesisParameters :: ()
readPrivateKey :: ()
putPrivateKey :: ()
removePendingOrExpiredTx :: ()
updatePendingTxForExpiry :: ()
readLocalTxSubmissionPending :: ()
putLocalTxSubmission :: ()
getTx :: ()
readTxHistory :: ()
putTxHistory :: ()
readDelegationRewardBalance :: ()
putDelegationRewardBalance :: ()
putDelegationCertificate :: ()
isStakeKeyRegistered :: ()
readWalletMeta :: ()
putWalletMeta :: ()
listCheckpoints :: ()
readCheckpoint :: ()
putCheckpoint :: ()
walletsDB :: ()
listWallets :: ()
removeWallet :: ()
initializeWallet :: ()
..} -> do
    (ErrPostTx -> ErrSubmitTx)
-> ExceptT ErrPostTx IO () -> ExceptT ErrSubmitTx IO ()
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ErrPostTx -> ErrSubmitTx
ErrSubmitTxNetwork (ExceptT ErrPostTx IO () -> ExceptT ErrSubmitTx IO ())
-> ExceptT ErrPostTx IO () -> ExceptT ErrSubmitTx IO ()
forall a b. (a -> b) -> a -> b
$
        NetworkLayer IO Block -> SealedTx -> ExceptT ErrPostTx IO ()
forall (m :: * -> *) block.
NetworkLayer m block -> SealedTx -> ExceptT ErrPostTx m ()
postTx NetworkLayer IO Block
nw SealedTx
binary
    (stm (Either ErrSubmitTx ()) -> IO (Either ErrSubmitTx ()))
-> ExceptT ErrSubmitTx stm () -> ExceptT ErrSubmitTx IO ()
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT stm (Either ErrSubmitTx ()) -> IO (Either ErrSubmitTx ())
forall a. stm a -> IO a
atomically (ExceptT ErrSubmitTx stm () -> ExceptT ErrSubmitTx IO ())
-> ExceptT ErrSubmitTx stm () -> ExceptT ErrSubmitTx IO ()
forall a b. (a -> b) -> a -> b
$ do
        (ErrNoSuchWallet -> ErrSubmitTx)
-> ExceptT ErrNoSuchWallet stm () -> ExceptT ErrSubmitTx stm ()
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ErrNoSuchWallet -> ErrSubmitTx
ErrSubmitTxNoSuchWallet (ExceptT ErrNoSuchWallet stm () -> ExceptT ErrSubmitTx stm ())
-> ExceptT ErrNoSuchWallet stm () -> ExceptT ErrSubmitTx stm ()
forall a b. (a -> b) -> a -> b
$
            WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
putTxHistory WalletId
wid [(Tx
tx, TxMeta
meta)]
        (ErrPutLocalTxSubmission -> ErrSubmitTx)
-> ExceptT ErrPutLocalTxSubmission stm ()
-> ExceptT ErrSubmitTx stm ()
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ErrPutLocalTxSubmission -> ErrSubmitTx
handleLocalTxSubmissionErr (ExceptT ErrPutLocalTxSubmission stm ()
 -> ExceptT ErrSubmitTx stm ())
-> ExceptT ErrPutLocalTxSubmission stm ()
-> ExceptT ErrSubmitTx stm ()
forall a b. (a -> b) -> a -> b
$
            WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
putLocalTxSubmission WalletId
wid (Tx
tx Tx
-> ((Hash "Tx" -> Const (Hash "Tx") (Hash "Tx"))
    -> Tx -> Const (Hash "Tx") Tx)
-> Hash "Tx"
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "txId"
  ((Hash "Tx" -> Const (Hash "Tx") (Hash "Tx"))
   -> Tx -> Const (Hash "Tx") Tx)
(Hash "Tx" -> Const (Hash "Tx") (Hash "Tx"))
-> Tx -> Const (Hash "Tx") Tx
#txId) SealedTx
binary (TxMeta
meta TxMeta
-> ((SlotNo -> Const SlotNo SlotNo)
    -> TxMeta -> Const SlotNo TxMeta)
-> SlotNo
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "slotNo"
  ((SlotNo -> Const SlotNo SlotNo) -> TxMeta -> Const SlotNo TxMeta)
(SlotNo -> Const SlotNo SlotNo) -> TxMeta -> Const SlotNo TxMeta
#slotNo)
  where
    db :: DBLayer IO s k
db = ctx
ctx ctx
-> ((DBLayer IO s k -> Const (DBLayer IO s k) (DBLayer IO s k))
    -> ctx -> Const (DBLayer IO s k) ctx)
-> DBLayer IO s k
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx. HasDBLayer IO s k ctx => Lens' ctx (DBLayer IO s k)
forall (m :: * -> *) s (k :: Depth -> * -> *) ctx.
HasDBLayer m s k ctx =>
Lens' ctx (DBLayer m s k)
dbLayer @IO @s @k
    nw :: NetworkLayer IO Block
nw = ctx
ctx ctx
-> ((NetworkLayer IO Block
     -> Const (NetworkLayer IO Block) (NetworkLayer IO Block))
    -> ctx -> Const (NetworkLayer IO Block) ctx)
-> NetworkLayer IO Block
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. (NetworkLayer IO Block
 -> Const (NetworkLayer IO Block) (NetworkLayer IO Block))
-> ctx -> Const (NetworkLayer IO Block) ctx
forall (m :: * -> *) ctx.
HasNetworkLayer m ctx =>
Lens' ctx (NetworkLayer m Block)
networkLayer

    tr :: Tracer IO WalletWorkerLog
tr = ctx
ctx ctx
-> ((Tracer IO WalletWorkerLog
     -> Const (Tracer IO WalletWorkerLog) (Tracer IO WalletWorkerLog))
    -> ctx -> Const (Tracer IO WalletWorkerLog) ctx)
-> Tracer IO WalletWorkerLog
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. (Tracer IO WalletWorkerLog
 -> Const (Tracer IO WalletWorkerLog) (Tracer IO WalletWorkerLog))
-> ctx -> Const (Tracer IO WalletWorkerLog) ctx
forall (m :: * -> *) msg ctx.
HasLogger m msg ctx =>
Lens' ctx (Tracer m msg)
logger
    tr' :: Tracer IO (BracketLog' (Either ErrSubmitTx ()))
tr' = (BracketLog' (Either ErrSubmitTx ()) -> WalletWorkerLog)
-> Tracer IO WalletWorkerLog
-> Tracer IO (BracketLog' (Either ErrSubmitTx ()))
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (WalletLog -> WalletWorkerLog
MsgWallet (WalletLog -> WalletWorkerLog)
-> (BracketLog' (Either ErrSubmitTx ()) -> WalletLog)
-> BracketLog' (Either ErrSubmitTx ())
-> WalletWorkerLog
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxSubmitLog -> WalletLog
MsgTxSubmit (TxSubmitLog -> WalletLog)
-> (BracketLog' (Either ErrSubmitTx ()) -> TxSubmitLog)
-> BracketLog' (Either ErrSubmitTx ())
-> WalletLog
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx
-> TxMeta
-> SealedTx
-> BracketLog' (Either ErrSubmitTx ())
-> TxSubmitLog
MsgSubmitTx Tx
tx TxMeta
meta SealedTx
binary) Tracer IO WalletWorkerLog
tr

    handleLocalTxSubmissionErr :: ErrPutLocalTxSubmission -> ErrSubmitTx
handleLocalTxSubmissionErr = \case
        ErrPutLocalTxSubmissionNoSuchWallet ErrNoSuchWallet
e -> ErrNoSuchWallet -> ErrSubmitTx
ErrSubmitTxNoSuchWallet ErrNoSuchWallet
e
        ErrPutLocalTxSubmissionNoSuchTransaction ErrNoSuchTransaction
e -> ErrNoSuchTransaction -> ErrSubmitTx
ErrSubmitTxImpossible ErrNoSuchTransaction
e

-- | Broadcast an externally-signed transaction to the network.
--
-- NOTE: external transactions will not be added to the LocalTxSubmission pool,
-- so the user must retry submission themselves.
submitExternalTx
    :: forall ctx k.
        ( HasNetworkLayer IO ctx
        , HasTransactionLayer k ctx
        , HasLogger IO TxSubmitLog ctx
        )
    => ctx
    -> SealedTx
    -> ExceptT ErrPostTx IO Tx
submitExternalTx :: ctx -> SealedTx -> ExceptT ErrPostTx IO Tx
submitExternalTx ctx
ctx SealedTx
sealedTx = do
    -- FIXME: We read the current era to constrain the @sealedTx@ **twice**:
    -- once here for decodeTx, and once in postTx before submitting.
    AnyCardanoEra
era <- IO AnyCardanoEra -> ExceptT ErrPostTx IO AnyCardanoEra
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO AnyCardanoEra -> ExceptT ErrPostTx IO AnyCardanoEra)
-> IO AnyCardanoEra -> ExceptT ErrPostTx IO AnyCardanoEra
forall a b. (a -> b) -> a -> b
$ NetworkLayer IO Block -> IO AnyCardanoEra
forall (m :: * -> *) block. NetworkLayer m block -> m AnyCardanoEra
currentNodeEra NetworkLayer IO Block
nw
    let (Tx
tx, TokenMapWithScripts
_, TokenMapWithScripts
_, [Certificate]
_, Maybe ValidityIntervalExplicit
_) = TransactionLayer k SealedTx
-> AnyCardanoEra
-> SealedTx
-> (Tx, TokenMapWithScripts, TokenMapWithScripts, [Certificate],
    Maybe ValidityIntervalExplicit)
forall (k :: Depth -> * -> *) tx.
TransactionLayer k tx
-> AnyCardanoEra
-> tx
-> (Tx, TokenMapWithScripts, TokenMapWithScripts, [Certificate],
    Maybe ValidityIntervalExplicit)
decodeTx TransactionLayer k SealedTx
tl AnyCardanoEra
era SealedTx
sealedTx
    let trPost :: Tracer IO (BracketLog' (Either ErrPostTx Tx))
trPost = (BracketLog' (Either ErrPostTx Tx) -> TxSubmitLog)
-> Tracer IO TxSubmitLog
-> Tracer IO (BracketLog' (Either ErrPostTx Tx))
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (Hash "Tx" -> BracketLog' (Either ErrPostTx Tx) -> TxSubmitLog
MsgSubmitExternalTx (Tx
tx Tx
-> ((Hash "Tx" -> Const (Hash "Tx") (Hash "Tx"))
    -> Tx -> Const (Hash "Tx") Tx)
-> Hash "Tx"
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "txId"
  ((Hash "Tx" -> Const (Hash "Tx") (Hash "Tx"))
   -> Tx -> Const (Hash "Tx") Tx)
(Hash "Tx" -> Const (Hash "Tx") (Hash "Tx"))
-> Tx -> Const (Hash "Tx") Tx
#txId)) (ctx
ctx ctx
-> ((Tracer IO TxSubmitLog
     -> Const (Tracer IO TxSubmitLog) (Tracer IO TxSubmitLog))
    -> ctx -> Const (Tracer IO TxSubmitLog) ctx)
-> Tracer IO TxSubmitLog
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. (Tracer IO TxSubmitLog
 -> Const (Tracer IO TxSubmitLog) (Tracer IO TxSubmitLog))
-> ctx -> Const (Tracer IO TxSubmitLog) ctx
forall (m :: * -> *) msg ctx.
HasLogger m msg ctx =>
Lens' ctx (Tracer m msg)
logger)
    Tracer IO (BracketLog' (Either ErrPostTx Tx))
-> ExceptT ErrPostTx IO Tx -> ExceptT ErrPostTx IO Tx
forall (m :: * -> *) e r.
MonadUnliftIO m =>
Tracer m (BracketLog' (Either e r))
-> ExceptT e m r -> ExceptT e m r
traceResult Tracer IO (BracketLog' (Either ErrPostTx Tx))
trPost (ExceptT ErrPostTx IO Tx -> ExceptT ErrPostTx IO Tx)
-> ExceptT ErrPostTx IO Tx -> ExceptT ErrPostTx IO Tx
forall a b. (a -> b) -> a -> b
$ do
        NetworkLayer IO Block -> SealedTx -> ExceptT ErrPostTx IO ()
forall (m :: * -> *) block.
NetworkLayer m block -> SealedTx -> ExceptT ErrPostTx m ()
postTx NetworkLayer IO Block
nw SealedTx
sealedTx
        Tx -> ExceptT ErrPostTx IO Tx
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx
tx
  where
    tl :: TransactionLayer k SealedTx
tl = ctx
ctx ctx
-> ((TransactionLayer k SealedTx
     -> Const
          (TransactionLayer k SealedTx) (TransactionLayer k SealedTx))
    -> ctx -> Const (TransactionLayer k SealedTx) ctx)
-> TransactionLayer k SealedTx
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx.
HasTransactionLayer k ctx =>
Lens' ctx (TransactionLayer k SealedTx)
forall (k :: Depth -> * -> *) ctx.
HasTransactionLayer k ctx =>
Lens' ctx (TransactionLayer k SealedTx)
transactionLayer @k
    nw :: NetworkLayer IO Block
nw = ctx
ctx ctx
-> ((NetworkLayer IO Block
     -> Const (NetworkLayer IO Block) (NetworkLayer IO Block))
    -> ctx -> Const (NetworkLayer IO Block) ctx)
-> NetworkLayer IO Block
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. (NetworkLayer IO Block
 -> Const (NetworkLayer IO Block) (NetworkLayer IO Block))
-> ctx -> Const (NetworkLayer IO Block) ctx
forall (m :: * -> *) ctx.
HasNetworkLayer m ctx =>
Lens' ctx (NetworkLayer m Block)
networkLayer

-- | Remove a pending or expired transaction from the transaction history. This
-- happens at the request of the user. If the transaction is already on chain,
-- or is missing from the transaction history, an error will be returned.
--
-- If a 'Pending' transaction is removed, but later appears in a block, it will
-- be added back to the transaction history.
forgetTx
    :: forall ctx s k.
        ( HasDBLayer IO s k ctx
        )
    => ctx
    -> WalletId
    -> Hash "Tx"
    -> ExceptT ErrRemoveTx IO ()
forgetTx :: ctx -> WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx IO ()
forgetTx ctx
ctx WalletId
wid Hash "Tx"
tid = DBLayer IO s k
db DBLayer IO s k
-> (DBLayer IO s k -> ExceptT ErrRemoveTx IO ())
-> ExceptT ErrRemoveTx IO ()
forall a b. a -> (a -> b) -> b
& \DBLayer{stm [WalletId]
DBVar stm (DeltaMap WalletId (DeltaWalletState s))
WalletId -> stm [LocalTxSubmissionStatus SealedTx]
WalletId -> stm [ChainPoint]
WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
WalletId -> stm (Maybe GenesisParameters)
WalletId -> stm (Maybe WalletMetadata)
WalletId -> stm (Maybe (Wallet s))
WalletId -> stm Coin
WalletId -> ExceptT ErrNoSuchWallet stm Bool
WalletId -> ExceptT ErrNoSuchWallet stm ()
WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
forall a. stm a -> IO a
atomically :: forall a. stm a -> IO a
prune :: WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
rollbackTo :: WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
readGenesisParameters :: WalletId -> stm (Maybe GenesisParameters)
readPrivateKey :: WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
putPrivateKey :: WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
removePendingOrExpiredTx :: WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
updatePendingTxForExpiry :: WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
readLocalTxSubmissionPending :: WalletId -> stm [LocalTxSubmissionStatus SealedTx]
putLocalTxSubmission :: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
getTx :: WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
readTxHistory :: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
putTxHistory :: WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
readDelegationRewardBalance :: WalletId -> stm Coin
putDelegationRewardBalance :: WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
putDelegationCertificate :: WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
isStakeKeyRegistered :: WalletId -> ExceptT ErrNoSuchWallet stm Bool
readWalletMeta :: WalletId -> stm (Maybe WalletMetadata)
putWalletMeta :: WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
listCheckpoints :: WalletId -> stm [ChainPoint]
readCheckpoint :: WalletId -> stm (Maybe (Wallet s))
putCheckpoint :: WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
walletsDB :: DBVar stm (DeltaMap WalletId (DeltaWalletState s))
listWallets :: stm [WalletId]
removeWallet :: WalletId -> ExceptT ErrNoSuchWallet stm ()
initializeWallet :: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
atomically :: ()
prune :: ()
rollbackTo :: ()
readGenesisParameters :: ()
readPrivateKey :: ()
putPrivateKey :: ()
removePendingOrExpiredTx :: ()
updatePendingTxForExpiry :: ()
readLocalTxSubmissionPending :: ()
putLocalTxSubmission :: ()
getTx :: ()
readTxHistory :: ()
putTxHistory :: ()
readDelegationRewardBalance :: ()
putDelegationRewardBalance :: ()
putDelegationCertificate :: ()
isStakeKeyRegistered :: ()
readWalletMeta :: ()
putWalletMeta :: ()
listCheckpoints :: ()
readCheckpoint :: ()
putCheckpoint :: ()
walletsDB :: ()
listWallets :: ()
removeWallet :: ()
initializeWallet :: ()
..} -> do
    (stm (Either ErrRemoveTx ()) -> IO (Either ErrRemoveTx ()))
-> ExceptT ErrRemoveTx stm () -> ExceptT ErrRemoveTx IO ()
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT stm (Either ErrRemoveTx ()) -> IO (Either ErrRemoveTx ())
forall a. stm a -> IO a
atomically (ExceptT ErrRemoveTx stm () -> ExceptT ErrRemoveTx IO ())
-> ExceptT ErrRemoveTx stm () -> ExceptT ErrRemoveTx IO ()
forall a b. (a -> b) -> a -> b
$ WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
removePendingOrExpiredTx WalletId
wid Hash "Tx"
tid
  where
    db :: DBLayer IO s k
db = ctx
ctx ctx
-> ((DBLayer IO s k -> Const (DBLayer IO s k) (DBLayer IO s k))
    -> ctx -> Const (DBLayer IO s k) ctx)
-> DBLayer IO s k
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx. HasDBLayer IO s k ctx => Lens' ctx (DBLayer IO s k)
forall (m :: * -> *) s (k :: Depth -> * -> *) ctx.
HasDBLayer m s k ctx =>
Lens' ctx (DBLayer m s k)
dbLayer @IO @s @k

-- | Given a LocalTxSubmission record, calculate the slot when it should be
-- retried next.
--
-- The current implementation is really basic. Retry about once _n_ blocks.
scheduleLocalTxSubmission
    :: Word64  -- ^ Resubmission interval in terms of expected blocks.
    -> SlottingParameters
    -> LocalTxSubmissionStatus tx
    -> SlotNo
scheduleLocalTxSubmission :: Word64
-> SlottingParameters -> LocalTxSubmissionStatus tx -> SlotNo
scheduleLocalTxSubmission Word64
numBlocks SlottingParameters
sp LocalTxSubmissionStatus tx
st = (LocalTxSubmissionStatus tx
st LocalTxSubmissionStatus tx
-> ((SlotNo -> Const SlotNo SlotNo)
    -> LocalTxSubmissionStatus tx
    -> Const SlotNo (LocalTxSubmissionStatus tx))
-> SlotNo
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "latestSubmission"
  ((SlotNo -> Const SlotNo SlotNo)
   -> LocalTxSubmissionStatus tx
   -> Const SlotNo (LocalTxSubmissionStatus tx))
(SlotNo -> Const SlotNo SlotNo)
-> LocalTxSubmissionStatus tx
-> Const SlotNo (LocalTxSubmissionStatus tx)
#latestSubmission) SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
numSlots
  where
    numSlots :: SlotNo
numSlots = Word64 -> SlotNo
SlotNo (Double -> Word64
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
numBlocks Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
f))
    ActiveSlotCoefficient Double
f = SlottingParameters -> ActiveSlotCoefficient
getActiveSlotCoefficient SlottingParameters
sp

-- | Parameters for 'runLocalTxSubmissionPool'
data LocalTxSubmissionConfig = LocalTxSubmissionConfig
    { LocalTxSubmissionConfig -> DiffTime
rateLimit :: DiffTime
        -- ^ Minimum time between checks of pending transactions
    , LocalTxSubmissionConfig -> Word64
blockInterval :: Word64
        -- ^ Resubmission interval, in terms of expected blocks.
    } deriving ((forall x.
 LocalTxSubmissionConfig -> Rep LocalTxSubmissionConfig x)
-> (forall x.
    Rep LocalTxSubmissionConfig x -> LocalTxSubmissionConfig)
-> Generic LocalTxSubmissionConfig
forall x. Rep LocalTxSubmissionConfig x -> LocalTxSubmissionConfig
forall x. LocalTxSubmissionConfig -> Rep LocalTxSubmissionConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep LocalTxSubmissionConfig x -> LocalTxSubmissionConfig
$cfrom :: forall x. LocalTxSubmissionConfig -> Rep LocalTxSubmissionConfig x
Generic, Int -> LocalTxSubmissionConfig -> ShowS
[LocalTxSubmissionConfig] -> ShowS
LocalTxSubmissionConfig -> String
(Int -> LocalTxSubmissionConfig -> ShowS)
-> (LocalTxSubmissionConfig -> String)
-> ([LocalTxSubmissionConfig] -> ShowS)
-> Show LocalTxSubmissionConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LocalTxSubmissionConfig] -> ShowS
$cshowList :: [LocalTxSubmissionConfig] -> ShowS
show :: LocalTxSubmissionConfig -> String
$cshow :: LocalTxSubmissionConfig -> String
showsPrec :: Int -> LocalTxSubmissionConfig -> ShowS
$cshowsPrec :: Int -> LocalTxSubmissionConfig -> ShowS
Show, LocalTxSubmissionConfig -> LocalTxSubmissionConfig -> Bool
(LocalTxSubmissionConfig -> LocalTxSubmissionConfig -> Bool)
-> (LocalTxSubmissionConfig -> LocalTxSubmissionConfig -> Bool)
-> Eq LocalTxSubmissionConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LocalTxSubmissionConfig -> LocalTxSubmissionConfig -> Bool
$c/= :: LocalTxSubmissionConfig -> LocalTxSubmissionConfig -> Bool
== :: LocalTxSubmissionConfig -> LocalTxSubmissionConfig -> Bool
$c== :: LocalTxSubmissionConfig -> LocalTxSubmissionConfig -> Bool
Eq)

-- | The current default is to resubmit any pending transaction about once every
-- 10 blocks.
--
-- The default rate limit for checking the pending list is 1000ms.
defaultLocalTxSubmissionConfig :: LocalTxSubmissionConfig
defaultLocalTxSubmissionConfig :: LocalTxSubmissionConfig
defaultLocalTxSubmissionConfig = DiffTime -> Word64 -> LocalTxSubmissionConfig
LocalTxSubmissionConfig DiffTime
1 Word64
10

-- | Continuous process which monitors the chain tip and retries submission of
-- pending transactions as the chain lengthens.
--
-- Regardless of the frequency of chain updates, this function won't re-query
-- the database faster than the configured 'rateLimit'.
--
-- This only exits if the network layer 'watchNodeTip' function exits.
runLocalTxSubmissionPool
    :: forall ctx s k m.
        ( MonadUnliftIO m
        , MonadMonotonicTime m
        , HasLogger IO WalletWorkerLog ctx
        , HasNetworkLayer m ctx
        , HasDBLayer m s k ctx
        )
    => LocalTxSubmissionConfig
    -> ctx
    -> WalletId
    -> m ()
runLocalTxSubmissionPool :: LocalTxSubmissionConfig -> ctx -> WalletId -> m ()
runLocalTxSubmissionPool LocalTxSubmissionConfig
cfg ctx
ctx WalletId
wid = DBLayer m s k
db DBLayer m s k -> (DBLayer m s k -> m ()) -> m ()
forall a b. a -> (a -> b) -> b
& \DBLayer{stm [WalletId]
DBVar stm (DeltaMap WalletId (DeltaWalletState s))
WalletId -> stm [LocalTxSubmissionStatus SealedTx]
WalletId -> stm [ChainPoint]
WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
WalletId -> stm (Maybe GenesisParameters)
WalletId -> stm (Maybe WalletMetadata)
WalletId -> stm (Maybe (Wallet s))
WalletId -> stm Coin
WalletId -> ExceptT ErrNoSuchWallet stm Bool
WalletId -> ExceptT ErrNoSuchWallet stm ()
WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
forall a. stm a -> m a
atomically :: forall a. stm a -> m a
prune :: WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
rollbackTo :: WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
readGenesisParameters :: WalletId -> stm (Maybe GenesisParameters)
readPrivateKey :: WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
putPrivateKey :: WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
removePendingOrExpiredTx :: WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
updatePendingTxForExpiry :: WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
readLocalTxSubmissionPending :: WalletId -> stm [LocalTxSubmissionStatus SealedTx]
putLocalTxSubmission :: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
getTx :: WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
readTxHistory :: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
putTxHistory :: WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
readDelegationRewardBalance :: WalletId -> stm Coin
putDelegationRewardBalance :: WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
putDelegationCertificate :: WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
isStakeKeyRegistered :: WalletId -> ExceptT ErrNoSuchWallet stm Bool
readWalletMeta :: WalletId -> stm (Maybe WalletMetadata)
putWalletMeta :: WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
listCheckpoints :: WalletId -> stm [ChainPoint]
readCheckpoint :: WalletId -> stm (Maybe (Wallet s))
putCheckpoint :: WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
walletsDB :: DBVar stm (DeltaMap WalletId (DeltaWalletState s))
listWallets :: stm [WalletId]
removeWallet :: WalletId -> ExceptT ErrNoSuchWallet stm ()
initializeWallet :: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
atomically :: ()
prune :: ()
rollbackTo :: ()
readGenesisParameters :: ()
readPrivateKey :: ()
putPrivateKey :: ()
removePendingOrExpiredTx :: ()
updatePendingTxForExpiry :: ()
readLocalTxSubmissionPending :: ()
putLocalTxSubmission :: ()
getTx :: ()
readTxHistory :: ()
putTxHistory :: ()
readDelegationRewardBalance :: ()
putDelegationRewardBalance :: ()
putDelegationCertificate :: ()
isStakeKeyRegistered :: ()
readWalletMeta :: ()
putWalletMeta :: ()
listCheckpoints :: ()
readCheckpoint :: ()
putCheckpoint :: ()
walletsDB :: ()
listWallets :: ()
removeWallet :: ()
initializeWallet :: ()
..} -> do
    BlockHeader -> m ()
submitPending <- (BlockHeader -> m ()) -> m (BlockHeader -> m ())
rateLimited ((BlockHeader -> m ()) -> m (BlockHeader -> m ()))
-> (BlockHeader -> m ()) -> m (BlockHeader -> m ())
forall a b. (a -> b) -> a -> b
$ \BlockHeader
bh -> Tracer m BracketLog -> m () -> m ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
Tracer m BracketLog -> m a -> m a
bracketTracer Tracer m BracketLog
trBracket (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        SlottingParameters
sp <- NetworkLayer m Block -> m SlottingParameters
forall (m :: * -> *) block.
NetworkLayer m block -> m SlottingParameters
currentSlottingParameters NetworkLayer m Block
nw
        [LocalTxSubmissionStatus SealedTx]
pending <- stm [LocalTxSubmissionStatus SealedTx]
-> m [LocalTxSubmissionStatus SealedTx]
forall a. stm a -> m a
atomically (stm [LocalTxSubmissionStatus SealedTx]
 -> m [LocalTxSubmissionStatus SealedTx])
-> stm [LocalTxSubmissionStatus SealedTx]
-> m [LocalTxSubmissionStatus SealedTx]
forall a b. (a -> b) -> a -> b
$ WalletId -> stm [LocalTxSubmissionStatus SealedTx]
readLocalTxSubmissionPending WalletId
wid
        let sl :: SlotNo
sl = BlockHeader
bh BlockHeader
-> ((SlotNo -> Const SlotNo SlotNo)
    -> BlockHeader -> Const SlotNo BlockHeader)
-> SlotNo
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "slotNo"
  ((SlotNo -> Const SlotNo SlotNo)
   -> BlockHeader -> Const SlotNo BlockHeader)
(SlotNo -> Const SlotNo SlotNo)
-> BlockHeader -> Const SlotNo BlockHeader
#slotNo
        -- Re-submit transactions due, ignore errors
        [LocalTxSubmissionStatus SealedTx]
-> (LocalTxSubmissionStatus SealedTx
    -> m (Either ErrPutLocalTxSubmission ()))
-> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ((LocalTxSubmissionStatus SealedTx -> Bool)
-> [LocalTxSubmissionStatus SealedTx]
-> [LocalTxSubmissionStatus SealedTx]
forall a. (a -> Bool) -> [a] -> [a]
filter (SlottingParameters
-> SlotNo -> LocalTxSubmissionStatus SealedTx -> Bool
isScheduled SlottingParameters
sp SlotNo
sl) [LocalTxSubmissionStatus SealedTx]
pending) ((LocalTxSubmissionStatus SealedTx
  -> m (Either ErrPutLocalTxSubmission ()))
 -> m ())
-> (LocalTxSubmissionStatus SealedTx
    -> m (Either ErrPutLocalTxSubmission ()))
-> m ()
forall a b. (a -> b) -> a -> b
$ \LocalTxSubmissionStatus SealedTx
st -> do
            Either ErrPostTx ()
_ <- ExceptT ErrPostTx m () -> m (Either ErrPostTx ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ErrPostTx m () -> m (Either ErrPostTx ()))
-> ExceptT ErrPostTx m () -> m (Either ErrPostTx ())
forall a b. (a -> b) -> a -> b
$ Tracer m (BracketLog' (Either ErrPostTx ()))
-> ExceptT ErrPostTx m () -> ExceptT ErrPostTx m ()
forall (m :: * -> *) e r.
MonadUnliftIO m =>
Tracer m (BracketLog' (Either e r))
-> ExceptT e m r -> ExceptT e m r
traceResult (Hash "Tx" -> Tracer m (BracketLog' (Either ErrPostTx ()))
trRetry (LocalTxSubmissionStatus SealedTx
st LocalTxSubmissionStatus SealedTx
-> ((Hash "Tx" -> Const (Hash "Tx") (Hash "Tx"))
    -> LocalTxSubmissionStatus SealedTx
    -> Const (Hash "Tx") (LocalTxSubmissionStatus SealedTx))
-> Hash "Tx"
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "txId"
  ((Hash "Tx" -> Const (Hash "Tx") (Hash "Tx"))
   -> LocalTxSubmissionStatus SealedTx
   -> Const (Hash "Tx") (LocalTxSubmissionStatus SealedTx))
(Hash "Tx" -> Const (Hash "Tx") (Hash "Tx"))
-> LocalTxSubmissionStatus SealedTx
-> Const (Hash "Tx") (LocalTxSubmissionStatus SealedTx)
#txId)) (ExceptT ErrPostTx m () -> ExceptT ErrPostTx m ())
-> ExceptT ErrPostTx m () -> ExceptT ErrPostTx m ()
forall a b. (a -> b) -> a -> b
$
                NetworkLayer m Block -> SealedTx -> ExceptT ErrPostTx m ()
forall (m :: * -> *) block.
NetworkLayer m block -> SealedTx -> ExceptT ErrPostTx m ()
postTx NetworkLayer m Block
nw (LocalTxSubmissionStatus SealedTx
st LocalTxSubmissionStatus SealedTx
-> ((SealedTx -> Const SealedTx SealedTx)
    -> LocalTxSubmissionStatus SealedTx
    -> Const SealedTx (LocalTxSubmissionStatus SealedTx))
-> SealedTx
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "submittedTx"
  ((SealedTx -> Const SealedTx SealedTx)
   -> LocalTxSubmissionStatus SealedTx
   -> Const SealedTx (LocalTxSubmissionStatus SealedTx))
(SealedTx -> Const SealedTx SealedTx)
-> LocalTxSubmissionStatus SealedTx
-> Const SealedTx (LocalTxSubmissionStatus SealedTx)
#submittedTx)
            stm (Either ErrPutLocalTxSubmission ())
-> m (Either ErrPutLocalTxSubmission ())
forall a. stm a -> m a
atomically (stm (Either ErrPutLocalTxSubmission ())
 -> m (Either ErrPutLocalTxSubmission ()))
-> stm (Either ErrPutLocalTxSubmission ())
-> m (Either ErrPutLocalTxSubmission ())
forall a b. (a -> b) -> a -> b
$ ExceptT ErrPutLocalTxSubmission stm ()
-> stm (Either ErrPutLocalTxSubmission ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ErrPutLocalTxSubmission stm ()
 -> stm (Either ErrPutLocalTxSubmission ()))
-> ExceptT ErrPutLocalTxSubmission stm ()
-> stm (Either ErrPutLocalTxSubmission ())
forall a b. (a -> b) -> a -> b
$ WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
putLocalTxSubmission
                WalletId
wid
                (LocalTxSubmissionStatus SealedTx
st LocalTxSubmissionStatus SealedTx
-> ((Hash "Tx" -> Const (Hash "Tx") (Hash "Tx"))
    -> LocalTxSubmissionStatus SealedTx
    -> Const (Hash "Tx") (LocalTxSubmissionStatus SealedTx))
-> Hash "Tx"
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "txId"
  ((Hash "Tx" -> Const (Hash "Tx") (Hash "Tx"))
   -> LocalTxSubmissionStatus SealedTx
   -> Const (Hash "Tx") (LocalTxSubmissionStatus SealedTx))
(Hash "Tx" -> Const (Hash "Tx") (Hash "Tx"))
-> LocalTxSubmissionStatus SealedTx
-> Const (Hash "Tx") (LocalTxSubmissionStatus SealedTx)
#txId)
                (LocalTxSubmissionStatus SealedTx
st LocalTxSubmissionStatus SealedTx
-> ((SealedTx -> Const SealedTx SealedTx)
    -> LocalTxSubmissionStatus SealedTx
    -> Const SealedTx (LocalTxSubmissionStatus SealedTx))
-> SealedTx
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "submittedTx"
  ((SealedTx -> Const SealedTx SealedTx)
   -> LocalTxSubmissionStatus SealedTx
   -> Const SealedTx (LocalTxSubmissionStatus SealedTx))
(SealedTx -> Const SealedTx SealedTx)
-> LocalTxSubmissionStatus SealedTx
-> Const SealedTx (LocalTxSubmissionStatus SealedTx)
#submittedTx)
                SlotNo
sl
    NetworkLayer m Block -> (BlockHeader -> m ()) -> m ()
forall (m :: * -> *) block.
NetworkLayer m block -> (BlockHeader -> m ()) -> m ()
watchNodeTip NetworkLayer m Block
nw BlockHeader -> m ()
submitPending
  where
    nw :: NetworkLayer m Block
nw = ctx
ctx ctx
-> ((NetworkLayer m Block
     -> Const (NetworkLayer m Block) (NetworkLayer m Block))
    -> ctx -> Const (NetworkLayer m Block) ctx)
-> NetworkLayer m Block
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx.
HasNetworkLayer m ctx =>
Lens' ctx (NetworkLayer m Block)
forall (m :: * -> *) ctx.
HasNetworkLayer m ctx =>
Lens' ctx (NetworkLayer m Block)
networkLayer @m
    db :: DBLayer m s k
db = ctx
ctx ctx
-> ((DBLayer m s k -> Const (DBLayer m s k) (DBLayer m s k))
    -> ctx -> Const (DBLayer m s k) ctx)
-> DBLayer m s k
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx. HasDBLayer m s k ctx => Lens' ctx (DBLayer m s k)
forall (m :: * -> *) s (k :: Depth -> * -> *) ctx.
HasDBLayer m s k ctx =>
Lens' ctx (DBLayer m s k)
dbLayer @m @s @k

    isScheduled :: SlottingParameters
-> SlotNo -> LocalTxSubmissionStatus SealedTx -> Bool
isScheduled SlottingParameters
sp SlotNo
now =
        (SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
<= SlotNo
now) (SlotNo -> Bool)
-> (LocalTxSubmissionStatus SealedTx -> SlotNo)
-> LocalTxSubmissionStatus SealedTx
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64
-> SlottingParameters -> LocalTxSubmissionStatus SealedTx -> SlotNo
forall tx.
Word64
-> SlottingParameters -> LocalTxSubmissionStatus tx -> SlotNo
scheduleLocalTxSubmission (LocalTxSubmissionConfig -> Word64
blockInterval LocalTxSubmissionConfig
cfg) SlottingParameters
sp

    rateLimited :: (BlockHeader -> m ()) -> m (BlockHeader -> m ())
rateLimited = DiffTime
-> (Time -> BlockHeader -> m ()) -> m (BlockHeader -> m ())
forall (m :: * -> *) a.
(MonadUnliftIO m, MonadMonotonicTime m) =>
DiffTime -> (Time -> a -> m ()) -> m (a -> m ())
throttle (LocalTxSubmissionConfig -> DiffTime
rateLimit LocalTxSubmissionConfig
cfg) ((Time -> BlockHeader -> m ()) -> m (BlockHeader -> m ()))
-> ((BlockHeader -> m ()) -> Time -> BlockHeader -> m ())
-> (BlockHeader -> m ())
-> m (BlockHeader -> m ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BlockHeader -> m ()) -> Time -> BlockHeader -> m ()
forall a b. a -> b -> a
const

    tr :: Tracer m TxSubmitLog
tr = Tracer IO TxSubmitLog -> Tracer m TxSubmitLog
forall (m :: * -> *) a. MonadIO m => Tracer IO a -> Tracer m a
unliftIOTracer (Tracer IO TxSubmitLog -> Tracer m TxSubmitLog)
-> Tracer IO TxSubmitLog -> Tracer m TxSubmitLog
forall a b. (a -> b) -> a -> b
$ (TxSubmitLog -> WalletWorkerLog)
-> Tracer IO WalletWorkerLog -> Tracer IO TxSubmitLog
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (WalletLog -> WalletWorkerLog
MsgWallet (WalletLog -> WalletWorkerLog)
-> (TxSubmitLog -> WalletLog) -> TxSubmitLog -> WalletWorkerLog
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxSubmitLog -> WalletLog
MsgTxSubmit) (Tracer IO WalletWorkerLog -> Tracer IO TxSubmitLog)
-> Tracer IO WalletWorkerLog -> Tracer IO TxSubmitLog
forall a b. (a -> b) -> a -> b
$
        ctx
ctx ctx
-> ((Tracer IO WalletWorkerLog
     -> Const (Tracer IO WalletWorkerLog) (Tracer IO WalletWorkerLog))
    -> ctx -> Const (Tracer IO WalletWorkerLog) ctx)
-> Tracer IO WalletWorkerLog
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx.
HasLogger IO WalletWorkerLog ctx =>
Lens' ctx (Tracer IO WalletWorkerLog)
forall (m :: * -> *) msg ctx.
HasLogger m msg ctx =>
Lens' ctx (Tracer m msg)
logger @_ @WalletWorkerLog
    trBracket :: Tracer m BracketLog
trBracket = (BracketLog -> TxSubmitLog)
-> Tracer m TxSubmitLog -> Tracer m BracketLog
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap BracketLog -> TxSubmitLog
MsgProcessPendingPool Tracer m TxSubmitLog
tr
    trRetry :: Hash "Tx" -> Tracer m (BracketLog' (Either ErrPostTx ()))
trRetry Hash "Tx"
i = (BracketLog' (Either ErrPostTx ()) -> TxSubmitLog)
-> Tracer m TxSubmitLog
-> Tracer m (BracketLog' (Either ErrPostTx ()))
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (Hash "Tx" -> BracketLog' (Either ErrPostTx ()) -> TxSubmitLog
MsgRetryPostTx Hash "Tx"
i) Tracer m TxSubmitLog
tr

-- | Return a function to run an action at most once every _interval_.
throttle
    :: (MonadUnliftIO m, MonadMonotonicTime m)
    => DiffTime
    -> (Time -> a -> m ())
    -> m (a -> m ())
throttle :: DiffTime -> (Time -> a -> m ()) -> m (a -> m ())
throttle DiffTime
interval Time -> a -> m ()
action = do
    MVar (Maybe Time)
var <- Maybe Time -> m (MVar (Maybe Time))
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar Maybe Time
forall a. Maybe a
Nothing
    (a -> m ()) -> m (a -> m ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a -> m ()) -> m (a -> m ())) -> (a -> m ()) -> m (a -> m ())
forall a b. (a -> b) -> a -> b
$ \a
arg -> MVar (Maybe Time) -> (Maybe Time -> m (Maybe Time)) -> m ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
MVar a -> (a -> m a) -> m ()
modifyMVar_ MVar (Maybe Time)
var ((Maybe Time -> m (Maybe Time)) -> m ())
-> (Maybe Time -> m (Maybe Time)) -> m ()
forall a b. (a -> b) -> a -> b
$ \Maybe Time
prev -> do
        Time
now <- m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
        if (DiffTime -> (Time -> DiffTime) -> Maybe Time -> DiffTime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe DiffTime
interval (Time -> Time -> DiffTime
diffTime Time
now) Maybe Time
prev DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
>= DiffTime
interval)
           then Time -> a -> m ()
action Time
now a
arg m () -> Maybe Time -> m (Maybe Time)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Time -> Maybe Time
forall a. a -> Maybe a
Just Time
now
           else Maybe Time -> m (Maybe Time)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Time
prev

-- | List all transactions and metadata from history for a given wallet.
listTransactions
    :: forall ctx s k.
        ( HasDBLayer IO s k ctx
        , HasNetworkLayer IO ctx
        )
    => ctx
    -> WalletId
    -> Maybe Coin
        -- Inclusive minimum value of at least one withdrawal in each transaction
    -> Maybe UTCTime
        -- Inclusive minimum time bound.
    -> Maybe UTCTime
        -- Inclusive maximum time bound.
    -> SortOrder
    -> ExceptT ErrListTransactions IO [TransactionInfo]
listTransactions :: ctx
-> WalletId
-> Maybe Coin
-> Maybe UTCTime
-> Maybe UTCTime
-> SortOrder
-> ExceptT ErrListTransactions IO [TransactionInfo]
listTransactions ctx
ctx WalletId
wid Maybe Coin
mMinWithdrawal Maybe UTCTime
mStart Maybe UTCTime
mEnd SortOrder
order = DBLayer IO s k
db DBLayer IO s k
-> (DBLayer IO s k
    -> ExceptT ErrListTransactions IO [TransactionInfo])
-> ExceptT ErrListTransactions IO [TransactionInfo]
forall a b. a -> (a -> b) -> b
& \DBLayer{stm [WalletId]
DBVar stm (DeltaMap WalletId (DeltaWalletState s))
WalletId -> stm [LocalTxSubmissionStatus SealedTx]
WalletId -> stm [ChainPoint]
WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
WalletId -> stm (Maybe GenesisParameters)
WalletId -> stm (Maybe WalletMetadata)
WalletId -> stm (Maybe (Wallet s))
WalletId -> stm Coin
WalletId -> ExceptT ErrNoSuchWallet stm Bool
WalletId -> ExceptT ErrNoSuchWallet stm ()
WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
forall a. stm a -> IO a
atomically :: forall a. stm a -> IO a
prune :: WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
rollbackTo :: WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
readGenesisParameters :: WalletId -> stm (Maybe GenesisParameters)
readPrivateKey :: WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
putPrivateKey :: WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
removePendingOrExpiredTx :: WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
updatePendingTxForExpiry :: WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
readLocalTxSubmissionPending :: WalletId -> stm [LocalTxSubmissionStatus SealedTx]
putLocalTxSubmission :: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
getTx :: WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
readTxHistory :: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
putTxHistory :: WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
readDelegationRewardBalance :: WalletId -> stm Coin
putDelegationRewardBalance :: WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
putDelegationCertificate :: WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
isStakeKeyRegistered :: WalletId -> ExceptT ErrNoSuchWallet stm Bool
readWalletMeta :: WalletId -> stm (Maybe WalletMetadata)
putWalletMeta :: WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
listCheckpoints :: WalletId -> stm [ChainPoint]
readCheckpoint :: WalletId -> stm (Maybe (Wallet s))
putCheckpoint :: WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
walletsDB :: DBVar stm (DeltaMap WalletId (DeltaWalletState s))
listWallets :: stm [WalletId]
removeWallet :: WalletId -> ExceptT ErrNoSuchWallet stm ()
initializeWallet :: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
atomically :: ()
prune :: ()
rollbackTo :: ()
readGenesisParameters :: ()
readPrivateKey :: ()
putPrivateKey :: ()
removePendingOrExpiredTx :: ()
updatePendingTxForExpiry :: ()
readLocalTxSubmissionPending :: ()
putLocalTxSubmission :: ()
getTx :: ()
readTxHistory :: ()
putTxHistory :: ()
readDelegationRewardBalance :: ()
putDelegationRewardBalance :: ()
putDelegationCertificate :: ()
isStakeKeyRegistered :: ()
readWalletMeta :: ()
putWalletMeta :: ()
listCheckpoints :: ()
readCheckpoint :: ()
putCheckpoint :: ()
walletsDB :: ()
listWallets :: ()
removeWallet :: ()
initializeWallet :: ()
..} -> do
    Bool
-> ExceptT ErrListTransactions IO ()
-> ExceptT ErrListTransactions IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== ( (Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
<(Natural -> Coin
Coin Natural
1)) (Coin -> Bool) -> Maybe Coin -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Coin
mMinWithdrawal )) (ExceptT ErrListTransactions IO ()
 -> ExceptT ErrListTransactions IO ())
-> ExceptT ErrListTransactions IO ()
-> ExceptT ErrListTransactions IO ()
forall a b. (a -> b) -> a -> b
$
        ErrListTransactions -> ExceptT ErrListTransactions IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ErrListTransactions
ErrListTransactionsMinWithdrawalWrong
    (stm (Either ErrListTransactions [TransactionInfo])
 -> IO (Either ErrListTransactions [TransactionInfo]))
-> ExceptT ErrListTransactions stm [TransactionInfo]
-> ExceptT ErrListTransactions IO [TransactionInfo]
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT stm (Either ErrListTransactions [TransactionInfo])
-> IO (Either ErrListTransactions [TransactionInfo])
forall a. stm a -> IO a
atomically (ExceptT ErrListTransactions stm [TransactionInfo]
 -> ExceptT ErrListTransactions IO [TransactionInfo])
-> ExceptT ErrListTransactions stm [TransactionInfo]
-> ExceptT ErrListTransactions IO [TransactionInfo]
forall a b. (a -> b) -> a -> b
$ do
        (IO (Either ErrListTransactions (Maybe (Range SlotNo)))
 -> stm (Either ErrListTransactions (Maybe (Range SlotNo))))
-> ExceptT ErrListTransactions IO (Maybe (Range SlotNo))
-> ExceptT ErrListTransactions stm (Maybe (Range SlotNo))
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT IO (Either ErrListTransactions (Maybe (Range SlotNo)))
-> stm (Either ErrListTransactions (Maybe (Range SlotNo)))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ExceptT ErrListTransactions IO (Maybe (Range SlotNo))
getSlotRange ExceptT ErrListTransactions stm (Maybe (Range SlotNo))
-> (Maybe (Range SlotNo)
    -> ExceptT ErrListTransactions stm [TransactionInfo])
-> ExceptT ErrListTransactions stm [TransactionInfo]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ExceptT ErrListTransactions stm [TransactionInfo]
-> (Range SlotNo
    -> ExceptT ErrListTransactions stm [TransactionInfo])
-> Maybe (Range SlotNo)
-> ExceptT ErrListTransactions stm [TransactionInfo]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
            ([TransactionInfo]
-> ExceptT ErrListTransactions stm [TransactionInfo]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
            (\Range SlotNo
r -> stm [TransactionInfo]
-> ExceptT ErrListTransactions stm [TransactionInfo]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
readTxHistory WalletId
wid Maybe Coin
mMinWithdrawal SortOrder
order Range SlotNo
r Maybe TxStatus
forall a. Maybe a
Nothing))
  where
    ti :: TimeInterpreter (ExceptT PastHorizonException IO)
    ti :: TimeInterpreter (ExceptT PastHorizonException IO)
ti = NetworkLayer IO Block
-> TimeInterpreter (ExceptT PastHorizonException IO)
forall (m :: * -> *) block.
NetworkLayer m block
-> TimeInterpreter (ExceptT PastHorizonException m)
timeInterpreter (ctx
ctx ctx
-> ((NetworkLayer IO Block
     -> Const (NetworkLayer IO Block) (NetworkLayer IO Block))
    -> ctx -> Const (NetworkLayer IO Block) ctx)
-> NetworkLayer IO Block
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. (NetworkLayer IO Block
 -> Const (NetworkLayer IO Block) (NetworkLayer IO Block))
-> ctx -> Const (NetworkLayer IO Block) ctx
forall (m :: * -> *) ctx.
HasNetworkLayer m ctx =>
Lens' ctx (NetworkLayer m Block)
networkLayer)

    db :: DBLayer IO s k
db = ctx
ctx ctx
-> ((DBLayer IO s k -> Const (DBLayer IO s k) (DBLayer IO s k))
    -> ctx -> Const (DBLayer IO s k) ctx)
-> DBLayer IO s k
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx. HasDBLayer IO s k ctx => Lens' ctx (DBLayer IO s k)
forall (m :: * -> *) s (k :: Depth -> * -> *) ctx.
HasDBLayer m s k ctx =>
Lens' ctx (DBLayer m s k)
dbLayer @IO @s @k

    -- Transforms the user-specified time range into a slot range. If the
    -- user-specified range terminates before the start of the blockchain,
    -- returns 'Nothing'.
    getSlotRange
        :: ExceptT ErrListTransactions IO (Maybe (Range SlotNo))
    getSlotRange :: ExceptT ErrListTransactions IO (Maybe (Range SlotNo))
getSlotRange = case (Maybe UTCTime
mStart, Maybe UTCTime
mEnd) of
        (Just UTCTime
start, Just UTCTime
end) | UTCTime
start UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> UTCTime
end -> do
            let err :: ErrStartTimeLaterThanEndTime
err = UTCTime -> UTCTime -> ErrStartTimeLaterThanEndTime
ErrStartTimeLaterThanEndTime UTCTime
start UTCTime
end
            ErrListTransactions
-> ExceptT ErrListTransactions IO (Maybe (Range SlotNo))
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (ErrStartTimeLaterThanEndTime -> ErrListTransactions
ErrListTransactionsStartTimeLaterThanEndTime ErrStartTimeLaterThanEndTime
err)
        (Maybe UTCTime, Maybe UTCTime)
_ -> do
            (PastHorizonException -> ErrListTransactions)
-> ExceptT PastHorizonException IO (Maybe (Range SlotNo))
-> ExceptT ErrListTransactions IO (Maybe (Range SlotNo))
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT PastHorizonException -> ErrListTransactions
ErrListTransactionsPastHorizonException
                (ExceptT PastHorizonException IO (Maybe (Range SlotNo))
 -> ExceptT ErrListTransactions IO (Maybe (Range SlotNo)))
-> ExceptT PastHorizonException IO (Maybe (Range SlotNo))
-> ExceptT ErrListTransactions IO (Maybe (Range SlotNo))
forall a b. (a -> b) -> a -> b
$ TimeInterpreter (ExceptT PastHorizonException IO)
-> Qry (Maybe (Range SlotNo))
-> ExceptT PastHorizonException IO (Maybe (Range SlotNo))
forall (m :: * -> *) a.
(HasCallStack, Monad m) =>
TimeInterpreter m -> Qry a -> m a
interpretQuery TimeInterpreter (ExceptT PastHorizonException IO)
ti
                (Qry (Maybe (Range SlotNo))
 -> ExceptT PastHorizonException IO (Maybe (Range SlotNo)))
-> Qry (Maybe (Range SlotNo))
-> ExceptT PastHorizonException IO (Maybe (Range SlotNo))
forall a b. (a -> b) -> a -> b
$ Range UTCTime -> Qry (Maybe (Range SlotNo))
slotRangeFromTimeRange
                (Range UTCTime -> Qry (Maybe (Range SlotNo)))
-> Range UTCTime -> Qry (Maybe (Range SlotNo))
forall a b. (a -> b) -> a -> b
$ Maybe UTCTime -> Maybe UTCTime -> Range UTCTime
forall a. Maybe a -> Maybe a -> Range a
Range Maybe UTCTime
mStart Maybe UTCTime
mEnd

-- | Extract assets associated with a given wallet from its transaction history.
listAssets
    :: forall s k ctx. (HasDBLayer IO s k ctx, IsOurs s Address)
    => ctx
    -> WalletId
    -> ExceptT ErrNoSuchWallet IO (Set TokenMap.AssetId)
listAssets :: ctx -> WalletId -> ExceptT ErrNoSuchWallet IO (Set AssetId)
listAssets ctx
ctx WalletId
wid = DBLayer IO s k
db DBLayer IO s k
-> (DBLayer IO s k -> ExceptT ErrNoSuchWallet IO (Set AssetId))
-> ExceptT ErrNoSuchWallet IO (Set AssetId)
forall a b. a -> (a -> b) -> b
& \DBLayer{stm [WalletId]
DBVar stm (DeltaMap WalletId (DeltaWalletState s))
WalletId -> stm [LocalTxSubmissionStatus SealedTx]
WalletId -> stm [ChainPoint]
WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
WalletId -> stm (Maybe GenesisParameters)
WalletId -> stm (Maybe WalletMetadata)
WalletId -> stm (Maybe (Wallet s))
WalletId -> stm Coin
WalletId -> ExceptT ErrNoSuchWallet stm Bool
WalletId -> ExceptT ErrNoSuchWallet stm ()
WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
forall a. stm a -> IO a
atomically :: forall a. stm a -> IO a
prune :: WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
rollbackTo :: WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
readGenesisParameters :: WalletId -> stm (Maybe GenesisParameters)
readPrivateKey :: WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
putPrivateKey :: WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
removePendingOrExpiredTx :: WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
updatePendingTxForExpiry :: WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
readLocalTxSubmissionPending :: WalletId -> stm [LocalTxSubmissionStatus SealedTx]
putLocalTxSubmission :: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
getTx :: WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
readTxHistory :: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
putTxHistory :: WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
readDelegationRewardBalance :: WalletId -> stm Coin
putDelegationRewardBalance :: WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
putDelegationCertificate :: WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
isStakeKeyRegistered :: WalletId -> ExceptT ErrNoSuchWallet stm Bool
readWalletMeta :: WalletId -> stm (Maybe WalletMetadata)
putWalletMeta :: WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
listCheckpoints :: WalletId -> stm [ChainPoint]
readCheckpoint :: WalletId -> stm (Maybe (Wallet s))
putCheckpoint :: WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
walletsDB :: DBVar stm (DeltaMap WalletId (DeltaWalletState s))
listWallets :: stm [WalletId]
removeWallet :: WalletId -> ExceptT ErrNoSuchWallet stm ()
initializeWallet :: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
atomically :: ()
prune :: ()
rollbackTo :: ()
readGenesisParameters :: ()
readPrivateKey :: ()
putPrivateKey :: ()
removePendingOrExpiredTx :: ()
updatePendingTxForExpiry :: ()
readLocalTxSubmissionPending :: ()
putLocalTxSubmission :: ()
getTx :: ()
readTxHistory :: ()
putTxHistory :: ()
readDelegationRewardBalance :: ()
putDelegationRewardBalance :: ()
putDelegationCertificate :: ()
isStakeKeyRegistered :: ()
readWalletMeta :: ()
putWalletMeta :: ()
listCheckpoints :: ()
readCheckpoint :: ()
putCheckpoint :: ()
walletsDB :: ()
listWallets :: ()
removeWallet :: ()
initializeWallet :: ()
..} -> do
    Wallet s
cp <- (stm (Either ErrNoSuchWallet (Wallet s))
 -> IO (Either ErrNoSuchWallet (Wallet s)))
-> ExceptT ErrNoSuchWallet stm (Wallet s)
-> ExceptT ErrNoSuchWallet IO (Wallet s)
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT stm (Either ErrNoSuchWallet (Wallet s))
-> IO (Either ErrNoSuchWallet (Wallet s))
forall a. stm a -> IO a
atomically (ExceptT ErrNoSuchWallet stm (Wallet s)
 -> ExceptT ErrNoSuchWallet IO (Wallet s))
-> ExceptT ErrNoSuchWallet stm (Wallet s)
-> ExceptT ErrNoSuchWallet IO (Wallet s)
forall a b. (a -> b) -> a -> b
$ WalletId
-> stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s)
forall (m :: * -> *) a.
Monad m =>
WalletId -> m (Maybe a) -> ExceptT ErrNoSuchWallet m a
withNoSuchWallet WalletId
wid (stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s))
-> stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s)
forall a b. (a -> b) -> a -> b
$ WalletId -> stm (Maybe (Wallet s))
readCheckpoint WalletId
wid
    [TransactionInfo]
txs <- IO [TransactionInfo]
-> ExceptT ErrNoSuchWallet IO [TransactionInfo]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO [TransactionInfo]
 -> ExceptT ErrNoSuchWallet IO [TransactionInfo])
-> (stm [TransactionInfo] -> IO [TransactionInfo])
-> stm [TransactionInfo]
-> ExceptT ErrNoSuchWallet IO [TransactionInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. stm [TransactionInfo] -> IO [TransactionInfo]
forall a. stm a -> IO a
atomically (stm [TransactionInfo]
 -> ExceptT ErrNoSuchWallet IO [TransactionInfo])
-> stm [TransactionInfo]
-> ExceptT ErrNoSuchWallet IO [TransactionInfo]
forall a b. (a -> b) -> a -> b
$
        let noMinWithdrawal :: Maybe a
noMinWithdrawal = Maybe a
forall a. Maybe a
Nothing
            allTxStatuses :: Maybe a
allTxStatuses = Maybe a
forall a. Maybe a
Nothing
        in WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
readTxHistory WalletId
wid Maybe Coin
forall a. Maybe a
noMinWithdrawal SortOrder
Ascending Range SlotNo
forall a. Range a
wholeRange Maybe TxStatus
forall a. Maybe a
allTxStatuses
    let txAssets :: TransactionInfo -> Set TokenMap.AssetId
        txAssets :: TransactionInfo -> Set AssetId
txAssets = [Set AssetId] -> Set AssetId
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions
            ([Set AssetId] -> Set AssetId)
-> (TransactionInfo -> [Set AssetId])
-> TransactionInfo
-> Set AssetId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxOut -> Set AssetId) -> [TxOut] -> [Set AssetId]
forall a b. (a -> b) -> [a] -> [b]
map (TokenBundle -> Set AssetId
TokenBundle.getAssets (TokenBundle -> Set AssetId)
-> (TxOut -> TokenBundle) -> TxOut -> Set AssetId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TokenBundle -> Const TokenBundle TokenBundle)
 -> TxOut -> Const TokenBundle TxOut)
-> TxOut -> TokenBundle
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "tokens"
  ((TokenBundle -> Const TokenBundle TokenBundle)
   -> TxOut -> Const TokenBundle TxOut)
(TokenBundle -> Const TokenBundle TokenBundle)
-> TxOut -> Const TokenBundle TxOut
#tokens)
            ([TxOut] -> [Set AssetId])
-> (TransactionInfo -> [TxOut]) -> TransactionInfo -> [Set AssetId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxOut -> Bool) -> [TxOut] -> [TxOut]
forall a. (a -> Bool) -> [a] -> [a]
filter TxOut -> Bool
ourOut
            ([TxOut] -> [TxOut])
-> (TransactionInfo -> [TxOut]) -> TransactionInfo -> [TxOut]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransactionInfo -> [TxOut]
txInfoOutputs
        ourOut :: TxOut -> Bool
ourOut TxOut{Address
$sel:address:TxOut :: TxOut -> Address
address :: Address
address} = Address -> Bool
ourAddress Address
address
        ourAddress :: Address -> Bool
ourAddress Address
addr = Maybe (NonEmpty DerivationIndex) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (NonEmpty DerivationIndex) -> Bool)
-> (s -> 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)
 -> Maybe (NonEmpty DerivationIndex))
-> (s -> (Maybe (NonEmpty DerivationIndex), s))
-> s
-> Maybe (NonEmpty DerivationIndex)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Address -> s -> (Maybe (NonEmpty DerivationIndex), s)
forall s entity.
IsOurs s entity =>
entity -> s -> (Maybe (NonEmpty DerivationIndex), s)
isOurs Address
addr (s -> Bool) -> s -> Bool
forall a b. (a -> b) -> a -> b
$ Wallet s -> s
forall s. Wallet s -> s
getState Wallet s
cp
    Set AssetId -> ExceptT ErrNoSuchWallet IO (Set AssetId)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set AssetId -> ExceptT ErrNoSuchWallet IO (Set AssetId))
-> Set AssetId -> ExceptT ErrNoSuchWallet IO (Set AssetId)
forall a b. (a -> b) -> a -> b
$ [Set AssetId] -> Set AssetId
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set AssetId] -> Set AssetId) -> [Set AssetId] -> Set AssetId
forall a b. (a -> b) -> a -> b
$ (TransactionInfo -> Set AssetId)
-> [TransactionInfo] -> [Set AssetId]
forall a b. (a -> b) -> [a] -> [b]
map TransactionInfo -> Set AssetId
txAssets [TransactionInfo]
txs
  where
    db :: DBLayer IO s k
db = ctx
ctx ctx
-> ((DBLayer IO s k -> Const (DBLayer IO s k) (DBLayer IO s k))
    -> ctx -> Const (DBLayer IO s k) ctx)
-> DBLayer IO s k
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx. HasDBLayer IO s k ctx => Lens' ctx (DBLayer IO s k)
forall (m :: * -> *) s (k :: Depth -> * -> *) ctx.
HasDBLayer m s k ctx =>
Lens' ctx (DBLayer m s k)
dbLayer @IO @s @k

-- | Get transaction and metadata from history for a given wallet.
getTransaction
    :: forall ctx s k. HasDBLayer IO s k ctx
    => ctx
    -> WalletId
    -> Hash "Tx"
    -> ExceptT ErrGetTransaction IO TransactionInfo
getTransaction :: ctx
-> WalletId
-> Hash "Tx"
-> ExceptT ErrGetTransaction IO TransactionInfo
getTransaction ctx
ctx WalletId
wid Hash "Tx"
tid = DBLayer IO s k
db DBLayer IO s k
-> (DBLayer IO s k -> ExceptT ErrGetTransaction IO TransactionInfo)
-> ExceptT ErrGetTransaction IO TransactionInfo
forall a b. a -> (a -> b) -> b
& \DBLayer{stm [WalletId]
DBVar stm (DeltaMap WalletId (DeltaWalletState s))
WalletId -> stm [LocalTxSubmissionStatus SealedTx]
WalletId -> stm [ChainPoint]
WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
WalletId -> stm (Maybe GenesisParameters)
WalletId -> stm (Maybe WalletMetadata)
WalletId -> stm (Maybe (Wallet s))
WalletId -> stm Coin
WalletId -> ExceptT ErrNoSuchWallet stm Bool
WalletId -> ExceptT ErrNoSuchWallet stm ()
WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
forall a. stm a -> IO a
atomically :: forall a. stm a -> IO a
prune :: WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
rollbackTo :: WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
readGenesisParameters :: WalletId -> stm (Maybe GenesisParameters)
readPrivateKey :: WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
putPrivateKey :: WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
removePendingOrExpiredTx :: WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
updatePendingTxForExpiry :: WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
readLocalTxSubmissionPending :: WalletId -> stm [LocalTxSubmissionStatus SealedTx]
putLocalTxSubmission :: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
getTx :: WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
readTxHistory :: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
putTxHistory :: WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
readDelegationRewardBalance :: WalletId -> stm Coin
putDelegationRewardBalance :: WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
putDelegationCertificate :: WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
isStakeKeyRegistered :: WalletId -> ExceptT ErrNoSuchWallet stm Bool
readWalletMeta :: WalletId -> stm (Maybe WalletMetadata)
putWalletMeta :: WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
listCheckpoints :: WalletId -> stm [ChainPoint]
readCheckpoint :: WalletId -> stm (Maybe (Wallet s))
putCheckpoint :: WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
walletsDB :: DBVar stm (DeltaMap WalletId (DeltaWalletState s))
listWallets :: stm [WalletId]
removeWallet :: WalletId -> ExceptT ErrNoSuchWallet stm ()
initializeWallet :: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
atomically :: ()
prune :: ()
rollbackTo :: ()
readGenesisParameters :: ()
readPrivateKey :: ()
putPrivateKey :: ()
removePendingOrExpiredTx :: ()
updatePendingTxForExpiry :: ()
readLocalTxSubmissionPending :: ()
putLocalTxSubmission :: ()
getTx :: ()
readTxHistory :: ()
putTxHistory :: ()
readDelegationRewardBalance :: ()
putDelegationRewardBalance :: ()
putDelegationCertificate :: ()
isStakeKeyRegistered :: ()
readWalletMeta :: ()
putWalletMeta :: ()
listCheckpoints :: ()
readCheckpoint :: ()
putCheckpoint :: ()
walletsDB :: ()
listWallets :: ()
removeWallet :: ()
initializeWallet :: ()
..} -> do
    Either ErrNoSuchWallet (Maybe TransactionInfo)
res <- IO (Either ErrNoSuchWallet (Maybe TransactionInfo))
-> ExceptT
     ErrGetTransaction
     IO
     (Either ErrNoSuchWallet (Maybe TransactionInfo))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Either ErrNoSuchWallet (Maybe TransactionInfo))
 -> ExceptT
      ErrGetTransaction
      IO
      (Either ErrNoSuchWallet (Maybe TransactionInfo)))
-> IO (Either ErrNoSuchWallet (Maybe TransactionInfo))
-> ExceptT
     ErrGetTransaction
     IO
     (Either ErrNoSuchWallet (Maybe TransactionInfo))
forall a b. (a -> b) -> a -> b
$ stm (Either ErrNoSuchWallet (Maybe TransactionInfo))
-> IO (Either ErrNoSuchWallet (Maybe TransactionInfo))
forall a. stm a -> IO a
atomically (stm (Either ErrNoSuchWallet (Maybe TransactionInfo))
 -> IO (Either ErrNoSuchWallet (Maybe TransactionInfo)))
-> stm (Either ErrNoSuchWallet (Maybe TransactionInfo))
-> IO (Either ErrNoSuchWallet (Maybe TransactionInfo))
forall a b. (a -> b) -> a -> b
$ ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
-> stm (Either ErrNoSuchWallet (Maybe TransactionInfo))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
 -> stm (Either ErrNoSuchWallet (Maybe TransactionInfo)))
-> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
-> stm (Either ErrNoSuchWallet (Maybe TransactionInfo))
forall a b. (a -> b) -> a -> b
$ WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
getTx WalletId
wid Hash "Tx"
tid
    case Either ErrNoSuchWallet (Maybe TransactionInfo)
res of
        Left ErrNoSuchWallet
err -> do
            ErrGetTransaction -> ExceptT ErrGetTransaction IO TransactionInfo
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (ErrNoSuchWallet -> ErrGetTransaction
ErrGetTransactionNoSuchWallet ErrNoSuchWallet
err)
        Right Maybe TransactionInfo
Nothing -> do
            let err' :: ErrNoSuchTransaction
err' = WalletId -> Hash "Tx" -> ErrNoSuchTransaction
ErrNoSuchTransaction WalletId
wid Hash "Tx"
tid
            ErrGetTransaction -> ExceptT ErrGetTransaction IO TransactionInfo
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (ErrNoSuchTransaction -> ErrGetTransaction
ErrGetTransactionNoSuchTransaction ErrNoSuchTransaction
err')
        Right (Just TransactionInfo
tx) ->
            TransactionInfo -> ExceptT ErrGetTransaction IO TransactionInfo
forall (f :: * -> *) a. Applicative f => a -> f a
pure TransactionInfo
tx
  where
    db :: DBLayer IO s k
db = ctx
ctx ctx
-> ((DBLayer IO s k -> Const (DBLayer IO s k) (DBLayer IO s k))
    -> ctx -> Const (DBLayer IO s k) ctx)
-> DBLayer IO s k
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx. HasDBLayer IO s k ctx => Lens' ctx (DBLayer IO s k)
forall (m :: * -> *) s (k :: Depth -> * -> *) ctx.
HasDBLayer m s k ctx =>
Lens' ctx (DBLayer m s k)
dbLayer @IO @s @k

{-------------------------------------------------------------------------------
                                  Migration
-------------------------------------------------------------------------------}

createMigrationPlan
    :: forall ctx k s.
        ( HasDBLayer IO s k ctx
        , HasNetworkLayer IO ctx
        , HasTransactionLayer k ctx
        )
    => ctx
    -> Cardano.AnyCardanoEra
    -> WalletId
    -> Withdrawal
    -> ExceptT ErrCreateMigrationPlan IO MigrationPlan
createMigrationPlan :: ctx
-> AnyCardanoEra
-> WalletId
-> Withdrawal
-> ExceptT ErrCreateMigrationPlan IO MigrationPlan
createMigrationPlan ctx
ctx AnyCardanoEra
era WalletId
wid Withdrawal
rewardWithdrawal = do
    (Wallet s
wallet, WalletMetadata
_, Set Tx
pending) <- (ErrNoSuchWallet -> ErrCreateMigrationPlan)
-> ExceptT ErrNoSuchWallet IO (Wallet s, WalletMetadata, Set Tx)
-> ExceptT
     ErrCreateMigrationPlan IO (Wallet s, WalletMetadata, Set Tx)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ErrNoSuchWallet -> ErrCreateMigrationPlan
ErrCreateMigrationPlanNoSuchWallet (ExceptT ErrNoSuchWallet IO (Wallet s, WalletMetadata, Set Tx)
 -> ExceptT
      ErrCreateMigrationPlan IO (Wallet s, WalletMetadata, Set Tx))
-> ExceptT ErrNoSuchWallet IO (Wallet s, WalletMetadata, Set Tx)
-> ExceptT
     ErrCreateMigrationPlan IO (Wallet s, WalletMetadata, Set Tx)
forall a b. (a -> b) -> a -> b
$
        ctx
-> WalletId
-> ExceptT ErrNoSuchWallet IO (Wallet s, WalletMetadata, Set Tx)
forall ctx s (k :: Depth -> * -> *).
HasDBLayer IO s k ctx =>
ctx
-> WalletId
-> ExceptT ErrNoSuchWallet IO (Wallet s, WalletMetadata, Set Tx)
readWallet @ctx @s @k ctx
ctx WalletId
wid
    ProtocolParameters
pp <- IO ProtocolParameters
-> ExceptT ErrCreateMigrationPlan IO ProtocolParameters
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProtocolParameters
 -> ExceptT ErrCreateMigrationPlan IO ProtocolParameters)
-> IO ProtocolParameters
-> ExceptT ErrCreateMigrationPlan IO ProtocolParameters
forall a b. (a -> b) -> a -> b
$ NetworkLayer IO Block -> IO ProtocolParameters
forall (m :: * -> *) block.
NetworkLayer m block -> m ProtocolParameters
currentProtocolParameters NetworkLayer IO Block
nl
    let txConstraints :: TxConstraints
txConstraints = TransactionLayer k SealedTx
-> AnyCardanoEra -> ProtocolParameters -> TxConstraints
forall (k :: Depth -> * -> *) tx.
TransactionLayer k tx
-> AnyCardanoEra -> ProtocolParameters -> TxConstraints
constraints TransactionLayer k SealedTx
tl AnyCardanoEra
era ProtocolParameters
pp
    let utxo :: UTxO
utxo = Set Tx -> Wallet s -> UTxO
forall s. Set Tx -> Wallet s -> UTxO
availableUTxO @s Set Tx
pending Wallet s
wallet
    MigrationPlan -> ExceptT ErrCreateMigrationPlan IO MigrationPlan
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (MigrationPlan -> ExceptT ErrCreateMigrationPlan IO MigrationPlan)
-> MigrationPlan -> ExceptT ErrCreateMigrationPlan IO MigrationPlan
forall a b. (a -> b) -> a -> b
$ TxConstraints -> UTxO -> RewardWithdrawal -> MigrationPlan
Migration.createPlan TxConstraints
txConstraints UTxO
utxo
        (RewardWithdrawal -> MigrationPlan)
-> RewardWithdrawal -> MigrationPlan
forall a b. (a -> b) -> a -> b
$ Coin -> RewardWithdrawal
Migration.RewardWithdrawal
        (Coin -> RewardWithdrawal) -> Coin -> RewardWithdrawal
forall a b. (a -> b) -> a -> b
$ Withdrawal -> Coin
withdrawalToCoin Withdrawal
rewardWithdrawal
  where
    nl :: NetworkLayer IO Block
nl = ctx
ctx ctx
-> ((NetworkLayer IO Block
     -> Const (NetworkLayer IO Block) (NetworkLayer IO Block))
    -> ctx -> Const (NetworkLayer IO Block) ctx)
-> NetworkLayer IO Block
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. (NetworkLayer IO Block
 -> Const (NetworkLayer IO Block) (NetworkLayer IO Block))
-> ctx -> Const (NetworkLayer IO Block) ctx
forall (m :: * -> *) ctx.
HasNetworkLayer m ctx =>
Lens' ctx (NetworkLayer m Block)
networkLayer
    tl :: TransactionLayer k SealedTx
tl = ctx
ctx ctx
-> ((TransactionLayer k SealedTx
     -> Const
          (TransactionLayer k SealedTx) (TransactionLayer k SealedTx))
    -> ctx -> Const (TransactionLayer k SealedTx) ctx)
-> TransactionLayer k SealedTx
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx.
HasTransactionLayer k ctx =>
Lens' ctx (TransactionLayer k SealedTx)
forall (k :: Depth -> * -> *) ctx.
HasTransactionLayer k ctx =>
Lens' ctx (TransactionLayer k SealedTx)
transactionLayer @k

type SelectionWithoutChange = SelectionOf Void

migrationPlanToSelectionWithdrawals
    :: MigrationPlan
    -> Withdrawal
    -> NonEmpty Address
    -> Maybe (NonEmpty (SelectionWithoutChange, Withdrawal))
migrationPlanToSelectionWithdrawals :: MigrationPlan
-> Withdrawal
-> NonEmpty Address
-> Maybe (NonEmpty (SelectionWithoutChange, Withdrawal))
migrationPlanToSelectionWithdrawals MigrationPlan
plan Withdrawal
rewardWithdrawal NonEmpty Address
outputAddressesToCycle
    = [(SelectionWithoutChange, Withdrawal)]
-> Maybe (NonEmpty (SelectionWithoutChange, Withdrawal))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty
    ([(SelectionWithoutChange, Withdrawal)]
 -> Maybe (NonEmpty (SelectionWithoutChange, Withdrawal)))
-> [(SelectionWithoutChange, Withdrawal)]
-> Maybe (NonEmpty (SelectionWithoutChange, Withdrawal))
forall a b. (a -> b) -> a -> b
$ [(SelectionWithoutChange, Withdrawal)]
-> [(SelectionWithoutChange, Withdrawal)]
forall a. [a] -> [a]
L.reverse
    ([(SelectionWithoutChange, Withdrawal)]
 -> [(SelectionWithoutChange, Withdrawal)])
-> [(SelectionWithoutChange, Withdrawal)]
-> [(SelectionWithoutChange, Withdrawal)]
forall a b. (a -> b) -> a -> b
$ ([(SelectionWithoutChange, Withdrawal)], [Address])
-> [(SelectionWithoutChange, Withdrawal)]
forall a b. (a, b) -> a
fst
    (([(SelectionWithoutChange, Withdrawal)], [Address])
 -> [(SelectionWithoutChange, Withdrawal)])
-> ([(SelectionWithoutChange, Withdrawal)], [Address])
-> [(SelectionWithoutChange, Withdrawal)]
forall a b. (a -> b) -> a -> b
$ (([(SelectionWithoutChange, Withdrawal)], [Address])
 -> Selection (TxIn, TxOut)
 -> ([(SelectionWithoutChange, Withdrawal)], [Address]))
-> ([(SelectionWithoutChange, Withdrawal)], [Address])
-> [Selection (TxIn, TxOut)]
-> ([(SelectionWithoutChange, Withdrawal)], [Address])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl'
        ((Selection (TxIn, TxOut)
 -> ([(SelectionWithoutChange, Withdrawal)], [Address])
 -> ([(SelectionWithoutChange, Withdrawal)], [Address]))
-> ([(SelectionWithoutChange, Withdrawal)], [Address])
-> Selection (TxIn, TxOut)
-> ([(SelectionWithoutChange, Withdrawal)], [Address])
forall a b c. (a -> b -> c) -> b -> a -> c
flip Selection (TxIn, TxOut)
-> ([(SelectionWithoutChange, Withdrawal)], [Address])
-> ([(SelectionWithoutChange, Withdrawal)], [Address])
accumulate)
        ([], NonEmpty Address -> [Address]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty Address -> [Address]) -> NonEmpty Address -> [Address]
forall a b. (a -> b) -> a -> b
$ NonEmpty Address -> NonEmpty Address
forall a. NonEmpty a -> NonEmpty a
NE.cycle NonEmpty Address
outputAddressesToCycle)
        ((([Selection (TxIn, TxOut)]
  -> Const [Selection (TxIn, TxOut)] [Selection (TxIn, TxOut)])
 -> MigrationPlan -> Const [Selection (TxIn, TxOut)] MigrationPlan)
-> MigrationPlan -> [Selection (TxIn, TxOut)]
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "selections"
  (([Selection (TxIn, TxOut)]
    -> Const [Selection (TxIn, TxOut)] [Selection (TxIn, TxOut)])
   -> MigrationPlan -> Const [Selection (TxIn, TxOut)] MigrationPlan)
([Selection (TxIn, TxOut)]
 -> Const [Selection (TxIn, TxOut)] [Selection (TxIn, TxOut)])
-> MigrationPlan -> Const [Selection (TxIn, TxOut)] MigrationPlan
#selections MigrationPlan
plan)
  where
    accumulate
        :: Migration.Selection (TxIn, TxOut)
        -> ([(SelectionWithoutChange, Withdrawal)], [Address])
        -> ([(SelectionWithoutChange, Withdrawal)], [Address])
    accumulate :: Selection (TxIn, TxOut)
-> ([(SelectionWithoutChange, Withdrawal)], [Address])
-> ([(SelectionWithoutChange, Withdrawal)], [Address])
accumulate Selection (TxIn, TxOut)
migrationSelection ([(SelectionWithoutChange, Withdrawal)]
selectionWithdrawals, [Address]
outputAddresses) =
        ( (SelectionWithoutChange
selection, Withdrawal
withdrawal) (SelectionWithoutChange, Withdrawal)
-> [(SelectionWithoutChange, Withdrawal)]
-> [(SelectionWithoutChange, Withdrawal)]
forall a. a -> [a] -> [a]
: [(SelectionWithoutChange, Withdrawal)]
selectionWithdrawals
        , [Address]
outputAddressesRemaining
        )
      where
        selection :: SelectionWithoutChange
selection = Selection :: forall change.
NonEmpty (TxIn, TxOut)
-> [(TxIn, TxOut)]
-> [TxOut]
-> [change]
-> TokenMap
-> TokenMap
-> Coin
-> Coin
-> SelectionOf change
Selection
            { $sel:inputs:Selection :: NonEmpty (TxIn, TxOut)
inputs = ((NonEmpty (TxIn, TxOut)
  -> Const (NonEmpty (TxIn, TxOut)) (NonEmpty (TxIn, TxOut)))
 -> Selection (TxIn, TxOut)
 -> Const (NonEmpty (TxIn, TxOut)) (Selection (TxIn, TxOut)))
-> Selection (TxIn, TxOut) -> NonEmpty (TxIn, TxOut)
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "inputIds"
  ((NonEmpty (TxIn, TxOut)
    -> Const (NonEmpty (TxIn, TxOut)) (NonEmpty (TxIn, TxOut)))
   -> Selection (TxIn, TxOut)
   -> Const (NonEmpty (TxIn, TxOut)) (Selection (TxIn, TxOut)))
(NonEmpty (TxIn, TxOut)
 -> Const (NonEmpty (TxIn, TxOut)) (NonEmpty (TxIn, TxOut)))
-> Selection (TxIn, TxOut)
-> Const (NonEmpty (TxIn, TxOut)) (Selection (TxIn, TxOut))
#inputIds Selection (TxIn, TxOut)
migrationSelection
            , $sel:collateral:Selection :: [(TxIn, TxOut)]
collateral = []
            , [TxOut]
$sel:outputs:Selection :: [TxOut]
outputs :: [TxOut]
outputs
            , Coin
$sel:extraCoinSource:Selection :: Coin
extraCoinSource :: Coin
extraCoinSource
            , $sel:extraCoinSink:Selection :: Coin
extraCoinSink = Natural -> Coin
Coin Natural
0
            , $sel:change:Selection :: [Void]
change = []
            , $sel:assetsToMint:Selection :: TokenMap
assetsToMint = TokenMap
TokenMap.empty
            , $sel:assetsToBurn:Selection :: TokenMap
assetsToBurn = TokenMap
TokenMap.empty
            }

        -- NOTE:
        --
        -- Due to a quirk of history, we need to populate the 'extraCoinSource'
        -- field with the reward withdrawal amount, since the transaction layer
        -- uses the 'selectionDelta' function to calculate the final fee, and
        -- that particular function doesn't know about reward withdrawals.
        --
        -- This is non-ideal, because we're returning the reward withdrawal
        -- amount in two places in the output of this function.
        --
        -- In future, it would be better to return a single record whose fields
        -- more closely resemble exactly what is needed to build a transaction,
        -- and have the transaction layer calculate the actual fee based only
        -- on the contents of that record.
        --
        extraCoinSource :: Coin
extraCoinSource = ((Coin -> Const Coin Coin)
 -> Selection (TxIn, TxOut) -> Const Coin (Selection (TxIn, TxOut)))
-> Selection (TxIn, TxOut) -> Coin
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "rewardWithdrawal"
  ((Coin -> Const Coin Coin)
   -> Selection (TxIn, TxOut) -> Const Coin (Selection (TxIn, TxOut)))
(Coin -> Const Coin Coin)
-> Selection (TxIn, TxOut) -> Const Coin (Selection (TxIn, TxOut))
#rewardWithdrawal Selection (TxIn, TxOut)
migrationSelection

        withdrawal :: Withdrawal
withdrawal =
            if (((Coin -> Const Coin Coin)
 -> Selection (TxIn, TxOut) -> Const Coin (Selection (TxIn, TxOut)))
-> Selection (TxIn, TxOut) -> Coin
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "rewardWithdrawal"
  ((Coin -> Const Coin Coin)
   -> Selection (TxIn, TxOut) -> Const Coin (Selection (TxIn, TxOut)))
(Coin -> Const Coin Coin)
-> Selection (TxIn, TxOut) -> Const Coin (Selection (TxIn, TxOut))
#rewardWithdrawal Selection (TxIn, TxOut)
migrationSelection) Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
> Natural -> Coin
Coin Natural
0
            then Withdrawal
rewardWithdrawal
            else Withdrawal
NoWithdrawal

        outputs :: [TxOut]
        outputs :: [TxOut]
outputs = (Address -> TokenBundle -> TxOut)
-> [Address] -> [TokenBundle] -> [TxOut]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Address -> TokenBundle -> TxOut
TxOut
            ([Address]
outputAddresses)
            (NonEmpty TokenBundle -> [TokenBundle]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty TokenBundle -> [TokenBundle])
-> NonEmpty TokenBundle -> [TokenBundle]
forall a b. (a -> b) -> a -> b
$ ((NonEmpty TokenBundle
  -> Const (NonEmpty TokenBundle) (NonEmpty TokenBundle))
 -> Selection (TxIn, TxOut)
 -> Const (NonEmpty TokenBundle) (Selection (TxIn, TxOut)))
-> Selection (TxIn, TxOut) -> NonEmpty TokenBundle
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "outputs"
  ((NonEmpty TokenBundle
    -> Const (NonEmpty TokenBundle) (NonEmpty TokenBundle))
   -> Selection (TxIn, TxOut)
   -> Const (NonEmpty TokenBundle) (Selection (TxIn, TxOut)))
(NonEmpty TokenBundle
 -> Const (NonEmpty TokenBundle) (NonEmpty TokenBundle))
-> Selection (TxIn, TxOut)
-> Const (NonEmpty TokenBundle) (Selection (TxIn, TxOut))
#outputs Selection (TxIn, TxOut)
migrationSelection)

        outputAddressesRemaining :: [Address]
        outputAddressesRemaining :: [Address]
outputAddressesRemaining =
            Int -> [Address] -> [Address]
forall a. Int -> [a] -> [a]
drop ([TxOut] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TxOut]
outputs) [Address]
outputAddresses

{-------------------------------------------------------------------------------
                                  Delegation
-------------------------------------------------------------------------------}

joinStakePool
    :: forall ctx s k.
        ( HasDBLayer IO s k ctx
        , HasNetworkLayer IO ctx
        , HasLogger IO WalletWorkerLog ctx
        )
    => ctx
    -> W.EpochNo
    -> Set PoolId
    -> PoolId
    -> PoolLifeCycleStatus
    -> WalletId
    -> ExceptT ErrStakePoolDelegation IO (DelegationAction, Maybe Coin)
    -- ^ snd is the deposit
joinStakePool :: ctx
-> EpochNo
-> Set PoolId
-> PoolId
-> PoolLifeCycleStatus
-> WalletId
-> ExceptT ErrStakePoolDelegation IO (DelegationAction, Maybe Coin)
joinStakePool ctx
ctx EpochNo
currentEpoch Set PoolId
knownPools PoolId
pid PoolLifeCycleStatus
poolStatus WalletId
wid =
    DBLayer IO s k
db DBLayer IO s k
-> (DBLayer IO s k
    -> ExceptT
         ErrStakePoolDelegation IO (DelegationAction, Maybe Coin))
-> ExceptT ErrStakePoolDelegation IO (DelegationAction, Maybe Coin)
forall a b. a -> (a -> b) -> b
& \DBLayer{stm [WalletId]
DBVar stm (DeltaMap WalletId (DeltaWalletState s))
WalletId -> stm [LocalTxSubmissionStatus SealedTx]
WalletId -> stm [ChainPoint]
WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
WalletId -> stm (Maybe GenesisParameters)
WalletId -> stm (Maybe WalletMetadata)
WalletId -> stm (Maybe (Wallet s))
WalletId -> stm Coin
WalletId -> ExceptT ErrNoSuchWallet stm Bool
WalletId -> ExceptT ErrNoSuchWallet stm ()
WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
forall a. stm a -> IO a
atomically :: forall a. stm a -> IO a
prune :: WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
rollbackTo :: WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
readGenesisParameters :: WalletId -> stm (Maybe GenesisParameters)
readPrivateKey :: WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
putPrivateKey :: WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
removePendingOrExpiredTx :: WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
updatePendingTxForExpiry :: WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
readLocalTxSubmissionPending :: WalletId -> stm [LocalTxSubmissionStatus SealedTx]
putLocalTxSubmission :: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
getTx :: WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
readTxHistory :: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
putTxHistory :: WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
readDelegationRewardBalance :: WalletId -> stm Coin
putDelegationRewardBalance :: WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
putDelegationCertificate :: WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
isStakeKeyRegistered :: WalletId -> ExceptT ErrNoSuchWallet stm Bool
readWalletMeta :: WalletId -> stm (Maybe WalletMetadata)
putWalletMeta :: WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
listCheckpoints :: WalletId -> stm [ChainPoint]
readCheckpoint :: WalletId -> stm (Maybe (Wallet s))
putCheckpoint :: WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
walletsDB :: DBVar stm (DeltaMap WalletId (DeltaWalletState s))
listWallets :: stm [WalletId]
removeWallet :: WalletId -> ExceptT ErrNoSuchWallet stm ()
initializeWallet :: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
atomically :: ()
prune :: ()
rollbackTo :: ()
readGenesisParameters :: ()
readPrivateKey :: ()
putPrivateKey :: ()
removePendingOrExpiredTx :: ()
updatePendingTxForExpiry :: ()
readLocalTxSubmissionPending :: ()
putLocalTxSubmission :: ()
getTx :: ()
readTxHistory :: ()
putTxHistory :: ()
readDelegationRewardBalance :: ()
putDelegationRewardBalance :: ()
putDelegationCertificate :: ()
isStakeKeyRegistered :: ()
readWalletMeta :: ()
putWalletMeta :: ()
listCheckpoints :: ()
readCheckpoint :: ()
putCheckpoint :: ()
walletsDB :: ()
listWallets :: ()
removeWallet :: ()
initializeWallet :: ()
..} -> do
        (WalletMetadata
walMeta, Bool
isKeyReg) <- (stm (Either ErrStakePoolDelegation (WalletMetadata, Bool))
 -> IO (Either ErrStakePoolDelegation (WalletMetadata, Bool)))
-> ExceptT ErrStakePoolDelegation stm (WalletMetadata, Bool)
-> ExceptT ErrStakePoolDelegation IO (WalletMetadata, Bool)
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT stm (Either ErrStakePoolDelegation (WalletMetadata, Bool))
-> IO (Either ErrStakePoolDelegation (WalletMetadata, Bool))
forall a. stm a -> IO a
atomically (ExceptT ErrStakePoolDelegation stm (WalletMetadata, Bool)
 -> ExceptT ErrStakePoolDelegation IO (WalletMetadata, Bool))
-> ExceptT ErrStakePoolDelegation stm (WalletMetadata, Bool)
-> ExceptT ErrStakePoolDelegation IO (WalletMetadata, Bool)
forall a b. (a -> b) -> a -> b
$ do
            WalletMetadata
walMeta <- (ErrNoSuchWallet -> ErrStakePoolDelegation)
-> ExceptT ErrNoSuchWallet stm WalletMetadata
-> ExceptT ErrStakePoolDelegation stm WalletMetadata
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ErrNoSuchWallet -> ErrStakePoolDelegation
ErrStakePoolDelegationNoSuchWallet
                (ExceptT ErrNoSuchWallet stm WalletMetadata
 -> ExceptT ErrStakePoolDelegation stm WalletMetadata)
-> ExceptT ErrNoSuchWallet stm WalletMetadata
-> ExceptT ErrStakePoolDelegation stm WalletMetadata
forall a b. (a -> b) -> a -> b
$ WalletId
-> stm (Maybe WalletMetadata)
-> ExceptT ErrNoSuchWallet stm WalletMetadata
forall (m :: * -> *) a.
Monad m =>
WalletId -> m (Maybe a) -> ExceptT ErrNoSuchWallet m a
withNoSuchWallet WalletId
wid
                (stm (Maybe WalletMetadata)
 -> ExceptT ErrNoSuchWallet stm WalletMetadata)
-> stm (Maybe WalletMetadata)
-> ExceptT ErrNoSuchWallet stm WalletMetadata
forall a b. (a -> b) -> a -> b
$ WalletId -> stm (Maybe WalletMetadata)
readWalletMeta WalletId
wid
            Bool
isKeyReg <- (ErrNoSuchWallet -> ErrStakePoolDelegation)
-> ExceptT ErrNoSuchWallet stm Bool
-> ExceptT ErrStakePoolDelegation stm Bool
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ErrNoSuchWallet -> ErrStakePoolDelegation
ErrStakePoolDelegationNoSuchWallet
                (ExceptT ErrNoSuchWallet stm Bool
 -> ExceptT ErrStakePoolDelegation stm Bool)
-> ExceptT ErrNoSuchWallet stm Bool
-> ExceptT ErrStakePoolDelegation stm Bool
forall a b. (a -> b) -> a -> b
$ WalletId -> ExceptT ErrNoSuchWallet stm Bool
isStakeKeyRegistered WalletId
wid
            (WalletMetadata, Bool)
-> ExceptT ErrStakePoolDelegation stm (WalletMetadata, Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WalletMetadata
walMeta, Bool
isKeyReg)

        let mRetirementEpoch :: Maybe EpochNo
mRetirementEpoch = ((EpochNo -> Const EpochNo EpochNo)
 -> PoolRetirementCertificate
 -> Const EpochNo PoolRetirementCertificate)
-> PoolRetirementCertificate -> EpochNo
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "retirementEpoch"
  ((EpochNo -> Const EpochNo EpochNo)
   -> PoolRetirementCertificate
   -> Const EpochNo PoolRetirementCertificate)
(EpochNo -> Const EpochNo EpochNo)
-> PoolRetirementCertificate
-> Const EpochNo PoolRetirementCertificate
#retirementEpoch (PoolRetirementCertificate -> EpochNo)
-> Maybe PoolRetirementCertificate -> Maybe EpochNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                PoolLifeCycleStatus -> Maybe PoolRetirementCertificate
W.getPoolRetirementCertificate PoolLifeCycleStatus
poolStatus
        let retirementInfo :: Maybe PoolRetirementEpochInfo
retirementInfo =
                EpochNo -> EpochNo -> PoolRetirementEpochInfo
PoolRetirementEpochInfo EpochNo
currentEpoch (EpochNo -> PoolRetirementEpochInfo)
-> Maybe EpochNo -> Maybe PoolRetirementEpochInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe EpochNo
mRetirementEpoch

        (ErrCannotJoin -> ErrStakePoolDelegation)
-> ExceptT ErrCannotJoin IO ()
-> ExceptT ErrStakePoolDelegation IO ()
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ErrCannotJoin -> ErrStakePoolDelegation
ErrStakePoolJoin (ExceptT ErrCannotJoin IO ()
 -> ExceptT ErrStakePoolDelegation IO ())
-> ExceptT ErrCannotJoin IO ()
-> ExceptT ErrStakePoolDelegation IO ()
forall a b. (a -> b) -> a -> b
$ Either ErrCannotJoin () -> ExceptT ErrCannotJoin IO ()
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either ErrCannotJoin () -> ExceptT ErrCannotJoin IO ())
-> Either ErrCannotJoin () -> ExceptT ErrCannotJoin IO ()
forall a b. (a -> b) -> a -> b
$
            Set PoolId
-> WalletDelegation
-> PoolId
-> Maybe PoolRetirementEpochInfo
-> Either ErrCannotJoin ()
guardJoin Set PoolId
knownPools (WalletMetadata
walMeta WalletMetadata
-> ((WalletDelegation -> Const WalletDelegation WalletDelegation)
    -> WalletMetadata -> Const WalletDelegation WalletMetadata)
-> WalletDelegation
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "delegation"
  ((WalletDelegation -> Const WalletDelegation WalletDelegation)
   -> WalletMetadata -> Const WalletDelegation WalletMetadata)
(WalletDelegation -> Const WalletDelegation WalletDelegation)
-> WalletMetadata -> Const WalletDelegation WalletMetadata
#delegation) PoolId
pid Maybe PoolRetirementEpochInfo
retirementInfo

        IO () -> ExceptT ErrStakePoolDelegation IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ErrStakePoolDelegation IO ())
-> IO () -> ExceptT ErrStakePoolDelegation IO ()
forall a b. (a -> b) -> a -> b
$ Tracer IO WalletLog -> WalletLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO WalletLog
tr (WalletLog -> IO ()) -> WalletLog -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> WalletLog
MsgIsStakeKeyRegistered Bool
isKeyReg

        Coin
dep <- IO Coin -> ExceptT ErrStakePoolDelegation IO Coin
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Coin -> ExceptT ErrStakePoolDelegation IO Coin)
-> IO Coin -> ExceptT ErrStakePoolDelegation IO Coin
forall a b. (a -> b) -> a -> b
$ ProtocolParameters -> Coin
stakeKeyDeposit (ProtocolParameters -> Coin) -> IO ProtocolParameters -> IO Coin
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NetworkLayer IO Block -> IO ProtocolParameters
forall (m :: * -> *) block.
NetworkLayer m block -> m ProtocolParameters
currentProtocolParameters NetworkLayer IO Block
nl

        (DelegationAction, Maybe Coin)
-> ExceptT ErrStakePoolDelegation IO (DelegationAction, Maybe Coin)
forall (m :: * -> *) a. Monad m => a -> m a
return ((DelegationAction, Maybe Coin)
 -> ExceptT
      ErrStakePoolDelegation IO (DelegationAction, Maybe Coin))
-> (DelegationAction, Maybe Coin)
-> ExceptT ErrStakePoolDelegation IO (DelegationAction, Maybe Coin)
forall a b. (a -> b) -> a -> b
$ if Bool
isKeyReg
            then (PoolId -> DelegationAction
Join PoolId
pid, Maybe Coin
forall a. Maybe a
Nothing)
            else (PoolId -> DelegationAction
RegisterKeyAndJoin PoolId
pid, Coin -> Maybe Coin
forall a. a -> Maybe a
Just Coin
dep)
  where
    db :: DBLayer IO s k
db = ctx
ctx ctx
-> ((DBLayer IO s k -> Const (DBLayer IO s k) (DBLayer IO s k))
    -> ctx -> Const (DBLayer IO s k) ctx)
-> DBLayer IO s k
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx. HasDBLayer IO s k ctx => Lens' ctx (DBLayer IO s k)
forall (m :: * -> *) s (k :: Depth -> * -> *) ctx.
HasDBLayer m s k ctx =>
Lens' ctx (DBLayer m s k)
dbLayer @IO @s @k
    tr :: Tracer IO WalletLog
tr = (WalletLog -> WalletWorkerLog)
-> Tracer IO WalletWorkerLog -> Tracer IO WalletLog
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap WalletLog -> WalletWorkerLog
MsgWallet (Tracer IO WalletWorkerLog -> Tracer IO WalletLog)
-> Tracer IO WalletWorkerLog -> Tracer IO WalletLog
forall a b. (a -> b) -> a -> b
$ ctx
ctx ctx
-> ((Tracer IO WalletWorkerLog
     -> Const (Tracer IO WalletWorkerLog) (Tracer IO WalletWorkerLog))
    -> ctx -> Const (Tracer IO WalletWorkerLog) ctx)
-> Tracer IO WalletWorkerLog
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. (Tracer IO WalletWorkerLog
 -> Const (Tracer IO WalletWorkerLog) (Tracer IO WalletWorkerLog))
-> ctx -> Const (Tracer IO WalletWorkerLog) ctx
forall (m :: * -> *) msg ctx.
HasLogger m msg ctx =>
Lens' ctx (Tracer m msg)
logger
    nl :: NetworkLayer IO Block
nl = ctx
ctx ctx
-> ((NetworkLayer IO Block
     -> Const (NetworkLayer IO Block) (NetworkLayer IO Block))
    -> ctx -> Const (NetworkLayer IO Block) ctx)
-> NetworkLayer IO Block
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. (NetworkLayer IO Block
 -> Const (NetworkLayer IO Block) (NetworkLayer IO Block))
-> ctx -> Const (NetworkLayer IO Block) ctx
forall (m :: * -> *) ctx.
HasNetworkLayer m ctx =>
Lens' ctx (NetworkLayer m Block)
networkLayer

-- | Helper function to factor necessary logic for quitting a stake pool.
quitStakePool
    :: forall ctx s k.
        ( HasDBLayer IO s k ctx
        )
    => ctx
    -> WalletId
    -> Withdrawal
    -> ExceptT ErrStakePoolDelegation IO DelegationAction
quitStakePool :: ctx
-> WalletId
-> Withdrawal
-> ExceptT ErrStakePoolDelegation IO DelegationAction
quitStakePool ctx
ctx WalletId
wid Withdrawal
wdrl = DBLayer IO s k
db DBLayer IO s k
-> (DBLayer IO s k
    -> ExceptT ErrStakePoolDelegation IO DelegationAction)
-> ExceptT ErrStakePoolDelegation IO DelegationAction
forall a b. a -> (a -> b) -> b
& \DBLayer{stm [WalletId]
DBVar stm (DeltaMap WalletId (DeltaWalletState s))
WalletId -> stm [LocalTxSubmissionStatus SealedTx]
WalletId -> stm [ChainPoint]
WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
WalletId -> stm (Maybe GenesisParameters)
WalletId -> stm (Maybe WalletMetadata)
WalletId -> stm (Maybe (Wallet s))
WalletId -> stm Coin
WalletId -> ExceptT ErrNoSuchWallet stm Bool
WalletId -> ExceptT ErrNoSuchWallet stm ()
WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
forall a. stm a -> IO a
atomically :: forall a. stm a -> IO a
prune :: WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
rollbackTo :: WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
readGenesisParameters :: WalletId -> stm (Maybe GenesisParameters)
readPrivateKey :: WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
putPrivateKey :: WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
removePendingOrExpiredTx :: WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
updatePendingTxForExpiry :: WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
readLocalTxSubmissionPending :: WalletId -> stm [LocalTxSubmissionStatus SealedTx]
putLocalTxSubmission :: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
getTx :: WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
readTxHistory :: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
putTxHistory :: WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
readDelegationRewardBalance :: WalletId -> stm Coin
putDelegationRewardBalance :: WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
putDelegationCertificate :: WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
isStakeKeyRegistered :: WalletId -> ExceptT ErrNoSuchWallet stm Bool
readWalletMeta :: WalletId -> stm (Maybe WalletMetadata)
putWalletMeta :: WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
listCheckpoints :: WalletId -> stm [ChainPoint]
readCheckpoint :: WalletId -> stm (Maybe (Wallet s))
putCheckpoint :: WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
walletsDB :: DBVar stm (DeltaMap WalletId (DeltaWalletState s))
listWallets :: stm [WalletId]
removeWallet :: WalletId -> ExceptT ErrNoSuchWallet stm ()
initializeWallet :: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
atomically :: ()
prune :: ()
rollbackTo :: ()
readGenesisParameters :: ()
readPrivateKey :: ()
putPrivateKey :: ()
removePendingOrExpiredTx :: ()
updatePendingTxForExpiry :: ()
readLocalTxSubmissionPending :: ()
putLocalTxSubmission :: ()
getTx :: ()
readTxHistory :: ()
putTxHistory :: ()
readDelegationRewardBalance :: ()
putDelegationRewardBalance :: ()
putDelegationCertificate :: ()
isStakeKeyRegistered :: ()
readWalletMeta :: ()
putWalletMeta :: ()
listCheckpoints :: ()
readCheckpoint :: ()
putCheckpoint :: ()
walletsDB :: ()
listWallets :: ()
removeWallet :: ()
initializeWallet :: ()
..} -> do
    WalletMetadata
walMeta <- (stm (Either ErrStakePoolDelegation WalletMetadata)
 -> IO (Either ErrStakePoolDelegation WalletMetadata))
-> ExceptT ErrStakePoolDelegation stm WalletMetadata
-> ExceptT ErrStakePoolDelegation IO WalletMetadata
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT stm (Either ErrStakePoolDelegation WalletMetadata)
-> IO (Either ErrStakePoolDelegation WalletMetadata)
forall a. stm a -> IO a
atomically
        (ExceptT ErrStakePoolDelegation stm WalletMetadata
 -> ExceptT ErrStakePoolDelegation IO WalletMetadata)
-> ExceptT ErrStakePoolDelegation stm WalletMetadata
-> ExceptT ErrStakePoolDelegation IO WalletMetadata
forall a b. (a -> b) -> a -> b
$ (ErrNoSuchWallet -> ErrStakePoolDelegation)
-> ExceptT ErrNoSuchWallet stm WalletMetadata
-> ExceptT ErrStakePoolDelegation stm WalletMetadata
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ErrNoSuchWallet -> ErrStakePoolDelegation
ErrStakePoolDelegationNoSuchWallet
        (ExceptT ErrNoSuchWallet stm WalletMetadata
 -> ExceptT ErrStakePoolDelegation stm WalletMetadata)
-> ExceptT ErrNoSuchWallet stm WalletMetadata
-> ExceptT ErrStakePoolDelegation stm WalletMetadata
forall a b. (a -> b) -> a -> b
$ WalletId
-> stm (Maybe WalletMetadata)
-> ExceptT ErrNoSuchWallet stm WalletMetadata
forall (m :: * -> *) a.
Monad m =>
WalletId -> m (Maybe a) -> ExceptT ErrNoSuchWallet m a
withNoSuchWallet WalletId
wid
        (stm (Maybe WalletMetadata)
 -> ExceptT ErrNoSuchWallet stm WalletMetadata)
-> stm (Maybe WalletMetadata)
-> ExceptT ErrNoSuchWallet stm WalletMetadata
forall a b. (a -> b) -> a -> b
$ WalletId -> stm (Maybe WalletMetadata)
readWalletMeta WalletId
wid

    Coin
rewards <- IO Coin -> ExceptT ErrStakePoolDelegation IO Coin
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
        (IO Coin -> ExceptT ErrStakePoolDelegation IO Coin)
-> IO Coin -> ExceptT ErrStakePoolDelegation IO Coin
forall a b. (a -> b) -> a -> b
$ ctx -> WalletId -> IO Coin
forall ctx s (k :: Depth -> * -> *).
HasDBLayer IO s k ctx =>
ctx -> WalletId -> IO Coin
fetchRewardBalance @ctx @s @k ctx
ctx WalletId
wid

    (ErrCannotQuit -> ErrStakePoolDelegation)
-> ExceptT ErrCannotQuit IO ()
-> ExceptT ErrStakePoolDelegation IO ()
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ErrCannotQuit -> ErrStakePoolDelegation
ErrStakePoolQuit (ExceptT ErrCannotQuit IO ()
 -> ExceptT ErrStakePoolDelegation IO ())
-> ExceptT ErrCannotQuit IO ()
-> ExceptT ErrStakePoolDelegation IO ()
forall a b. (a -> b) -> a -> b
$ Either ErrCannotQuit () -> ExceptT ErrCannotQuit IO ()
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either ErrCannotQuit () -> ExceptT ErrCannotQuit IO ())
-> Either ErrCannotQuit () -> ExceptT ErrCannotQuit IO ()
forall a b. (a -> b) -> a -> b
$
        WalletDelegation -> Withdrawal -> Coin -> Either ErrCannotQuit ()
guardQuit (WalletMetadata
walMeta WalletMetadata
-> ((WalletDelegation -> Const WalletDelegation WalletDelegation)
    -> WalletMetadata -> Const WalletDelegation WalletMetadata)
-> WalletDelegation
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "delegation"
  ((WalletDelegation -> Const WalletDelegation WalletDelegation)
   -> WalletMetadata -> Const WalletDelegation WalletMetadata)
(WalletDelegation -> Const WalletDelegation WalletDelegation)
-> WalletMetadata -> Const WalletDelegation WalletMetadata
#delegation) Withdrawal
wdrl Coin
rewards

    DelegationAction
-> ExceptT ErrStakePoolDelegation IO DelegationAction
forall (f :: * -> *) a. Applicative f => a -> f a
pure DelegationAction
Quit
  where
    db :: DBLayer IO s k
db = ctx
ctx ctx
-> ((DBLayer IO s k -> Const (DBLayer IO s k) (DBLayer IO s k))
    -> ctx -> Const (DBLayer IO s k) ctx)
-> DBLayer IO s k
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx. HasDBLayer IO s k ctx => Lens' ctx (DBLayer IO s k)
forall (m :: * -> *) s (k :: Depth -> * -> *) ctx.
HasDBLayer m s k ctx =>
Lens' ctx (DBLayer m s k)
dbLayer @IO @s @k

{-------------------------------------------------------------------------------
                                 Fee Estimation
-------------------------------------------------------------------------------}

-- | Result of a fee estimation process given a wallet and payment order.
data FeeEstimation = FeeEstimation
    { FeeEstimation -> Word64
estMinFee :: Word64
    -- ^ Most coin selections will result in a fee higher than this.
    , FeeEstimation -> Word64
estMaxFee :: Word64
    -- ^ Most coin selections will result in a fee lower than this.
    } deriving (Int -> FeeEstimation -> ShowS
[FeeEstimation] -> ShowS
FeeEstimation -> String
(Int -> FeeEstimation -> ShowS)
-> (FeeEstimation -> String)
-> ([FeeEstimation] -> ShowS)
-> Show FeeEstimation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FeeEstimation] -> ShowS
$cshowList :: [FeeEstimation] -> ShowS
show :: FeeEstimation -> String
$cshow :: FeeEstimation -> String
showsPrec :: Int -> FeeEstimation -> ShowS
$cshowsPrec :: Int -> FeeEstimation -> ShowS
Show, FeeEstimation -> FeeEstimation -> Bool
(FeeEstimation -> FeeEstimation -> Bool)
-> (FeeEstimation -> FeeEstimation -> Bool) -> Eq FeeEstimation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FeeEstimation -> FeeEstimation -> Bool
$c/= :: FeeEstimation -> FeeEstimation -> Bool
== :: FeeEstimation -> FeeEstimation -> Bool
$c== :: FeeEstimation -> FeeEstimation -> Bool
Eq, (forall x. FeeEstimation -> Rep FeeEstimation x)
-> (forall x. Rep FeeEstimation x -> FeeEstimation)
-> Generic FeeEstimation
forall x. Rep FeeEstimation x -> FeeEstimation
forall x. FeeEstimation -> Rep FeeEstimation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep FeeEstimation x -> FeeEstimation
$cfrom :: forall x. FeeEstimation -> Rep FeeEstimation x
Generic)

instance NFData FeeEstimation

-- | Calculate the minimum deposit necessary if a given wallet wanted to
-- delegate to a pool. Said differently, this return either 0, or the value of
-- the key deposit protocol parameters if the wallet has no registered stake
-- key.
calcMinimumDeposit
    :: forall ctx s k.
        ( HasDBLayer IO s k ctx
        , HasNetworkLayer IO ctx
        )
    => ctx
    -> WalletId
    -> ExceptT ErrSelectAssets IO Coin
calcMinimumDeposit :: ctx -> WalletId -> ExceptT ErrSelectAssets IO Coin
calcMinimumDeposit ctx
ctx WalletId
wid = DBLayer IO s k
db DBLayer IO s k
-> (DBLayer IO s k -> ExceptT ErrSelectAssets IO Coin)
-> ExceptT ErrSelectAssets IO Coin
forall a b. a -> (a -> b) -> b
& \DBLayer{stm [WalletId]
DBVar stm (DeltaMap WalletId (DeltaWalletState s))
WalletId -> stm [LocalTxSubmissionStatus SealedTx]
WalletId -> stm [ChainPoint]
WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
WalletId -> stm (Maybe GenesisParameters)
WalletId -> stm (Maybe WalletMetadata)
WalletId -> stm (Maybe (Wallet s))
WalletId -> stm Coin
WalletId -> ExceptT ErrNoSuchWallet stm Bool
WalletId -> ExceptT ErrNoSuchWallet stm ()
WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
forall a. stm a -> IO a
atomically :: forall a. stm a -> IO a
prune :: WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
rollbackTo :: WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
readGenesisParameters :: WalletId -> stm (Maybe GenesisParameters)
readPrivateKey :: WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
putPrivateKey :: WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
removePendingOrExpiredTx :: WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
updatePendingTxForExpiry :: WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
readLocalTxSubmissionPending :: WalletId -> stm [LocalTxSubmissionStatus SealedTx]
putLocalTxSubmission :: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
getTx :: WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
readTxHistory :: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
putTxHistory :: WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
readDelegationRewardBalance :: WalletId -> stm Coin
putDelegationRewardBalance :: WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
putDelegationCertificate :: WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
isStakeKeyRegistered :: WalletId -> ExceptT ErrNoSuchWallet stm Bool
readWalletMeta :: WalletId -> stm (Maybe WalletMetadata)
putWalletMeta :: WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
listCheckpoints :: WalletId -> stm [ChainPoint]
readCheckpoint :: WalletId -> stm (Maybe (Wallet s))
putCheckpoint :: WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
walletsDB :: DBVar stm (DeltaMap WalletId (DeltaWalletState s))
listWallets :: stm [WalletId]
removeWallet :: WalletId -> ExceptT ErrNoSuchWallet stm ()
initializeWallet :: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
atomically :: ()
prune :: ()
rollbackTo :: ()
readGenesisParameters :: ()
readPrivateKey :: ()
putPrivateKey :: ()
removePendingOrExpiredTx :: ()
updatePendingTxForExpiry :: ()
readLocalTxSubmissionPending :: ()
putLocalTxSubmission :: ()
getTx :: ()
readTxHistory :: ()
putTxHistory :: ()
readDelegationRewardBalance :: ()
putDelegationRewardBalance :: ()
putDelegationCertificate :: ()
isStakeKeyRegistered :: ()
readWalletMeta :: ()
putWalletMeta :: ()
listCheckpoints :: ()
readCheckpoint :: ()
putCheckpoint :: ()
walletsDB :: ()
listWallets :: ()
removeWallet :: ()
initializeWallet :: ()
..} ->
    (ErrNoSuchWallet -> ErrSelectAssets)
-> ExceptT ErrNoSuchWallet IO Coin
-> ExceptT ErrSelectAssets IO Coin
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ErrNoSuchWallet -> ErrSelectAssets
ErrSelectAssetsNoSuchWallet (ExceptT ErrNoSuchWallet IO Coin
 -> ExceptT ErrSelectAssets IO Coin)
-> ExceptT ErrNoSuchWallet IO Coin
-> ExceptT ErrSelectAssets IO Coin
forall a b. (a -> b) -> a -> b
$ do
        (stm (Either ErrNoSuchWallet Bool)
 -> IO (Either ErrNoSuchWallet Bool))
-> ExceptT ErrNoSuchWallet stm Bool
-> ExceptT ErrNoSuchWallet IO Bool
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT stm (Either ErrNoSuchWallet Bool)
-> IO (Either ErrNoSuchWallet Bool)
forall a. stm a -> IO a
atomically (WalletId -> ExceptT ErrNoSuchWallet stm Bool
isStakeKeyRegistered WalletId
wid) ExceptT ErrNoSuchWallet IO Bool
-> (Bool -> ExceptT ErrNoSuchWallet IO Coin)
-> ExceptT ErrNoSuchWallet IO Coin
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Bool
True ->
                Coin -> ExceptT ErrNoSuchWallet IO Coin
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Coin -> ExceptT ErrNoSuchWallet IO Coin)
-> Coin -> ExceptT ErrNoSuchWallet IO Coin
forall a b. (a -> b) -> a -> b
$ Natural -> Coin
Coin Natural
0
            Bool
False ->
                IO Coin -> ExceptT ErrNoSuchWallet IO Coin
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Coin -> ExceptT ErrNoSuchWallet IO Coin)
-> IO Coin -> ExceptT ErrNoSuchWallet IO Coin
forall a b. (a -> b) -> a -> b
$ ProtocolParameters -> Coin
stakeKeyDeposit (ProtocolParameters -> Coin) -> IO ProtocolParameters -> IO Coin
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NetworkLayer IO Block -> IO ProtocolParameters
forall (m :: * -> *) block.
NetworkLayer m block -> m ProtocolParameters
currentProtocolParameters NetworkLayer IO Block
nl
  where
    db :: DBLayer IO s k
db = ctx
ctx ctx
-> ((DBLayer IO s k -> Const (DBLayer IO s k) (DBLayer IO s k))
    -> ctx -> Const (DBLayer IO s k) ctx)
-> DBLayer IO s k
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx. HasDBLayer IO s k ctx => Lens' ctx (DBLayer IO s k)
forall (m :: * -> *) s (k :: Depth -> * -> *) ctx.
HasDBLayer m s k ctx =>
Lens' ctx (DBLayer m s k)
dbLayer @IO @s @k
    nl :: NetworkLayer IO Block
nl = ctx
ctx ctx
-> ((NetworkLayer IO Block
     -> Const (NetworkLayer IO Block) (NetworkLayer IO Block))
    -> ctx -> Const (NetworkLayer IO Block) ctx)
-> NetworkLayer IO Block
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. (NetworkLayer IO Block
 -> Const (NetworkLayer IO Block) (NetworkLayer IO Block))
-> ctx -> Const (NetworkLayer IO Block) ctx
forall (m :: * -> *) ctx.
HasNetworkLayer m ctx =>
Lens' ctx (NetworkLayer m Block)
networkLayer

-- | Estimate the transaction fee for a given coin selection algorithm by
-- repeatedly running it (100 times) and collecting the results. In the returned
-- 'FeeEstimation', the minimum fee is that which 90% of the sampled fees are
-- greater than. The maximum fee is the highest fee observed in the samples.
estimateFee
    :: forall m. Monad m
    => ExceptT ErrSelectAssets m Coin
    -> ExceptT ErrSelectAssets m FeeEstimation
estimateFee :: ExceptT ErrSelectAssets m Coin
-> ExceptT ErrSelectAssets m FeeEstimation
estimateFee
    = ([Natural] -> FeeEstimation)
-> ExceptT ErrSelectAssets m [Natural]
-> ExceptT ErrSelectAssets m FeeEstimation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Natural] -> FeeEstimation
deciles
    (ExceptT ErrSelectAssets m [Natural]
 -> ExceptT ErrSelectAssets m FeeEstimation)
-> (ExceptT ErrSelectAssets m Coin
    -> ExceptT ErrSelectAssets m [Natural])
-> ExceptT ErrSelectAssets m Coin
-> ExceptT ErrSelectAssets m FeeEstimation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m [Either ErrSelectAssets Natural]
-> ExceptT ErrSelectAssets m [Natural]
forall err a. m [Either err a] -> ExceptT err m [a]
handleErrors
    (m [Either ErrSelectAssets Natural]
 -> ExceptT ErrSelectAssets m [Natural])
-> (ExceptT ErrSelectAssets m Coin
    -> m [Either ErrSelectAssets Natural])
-> ExceptT ErrSelectAssets m Coin
-> ExceptT ErrSelectAssets m [Natural]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int
-> m (Either ErrSelectAssets Natural)
-> m [Either ErrSelectAssets Natural]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
repeats
    (m (Either ErrSelectAssets Natural)
 -> m [Either ErrSelectAssets Natural])
-> (ExceptT ErrSelectAssets m Coin
    -> m (Either ErrSelectAssets Natural))
-> ExceptT ErrSelectAssets m Coin
-> m [Either ErrSelectAssets Natural]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT ErrSelectAssets m Natural
-> m (Either ErrSelectAssets Natural)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
    (ExceptT ErrSelectAssets m Natural
 -> m (Either ErrSelectAssets Natural))
-> (ExceptT ErrSelectAssets m Coin
    -> ExceptT ErrSelectAssets m Natural)
-> ExceptT ErrSelectAssets m Coin
-> m (Either ErrSelectAssets Natural)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Natural)
-> ExceptT ErrSelectAssets m Coin
-> ExceptT ErrSelectAssets m Natural
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Coin -> Natural
unCoin
    (ExceptT ErrSelectAssets m Coin
 -> ExceptT ErrSelectAssets m Natural)
-> (ExceptT ErrSelectAssets m Coin
    -> ExceptT ErrSelectAssets m Coin)
-> ExceptT ErrSelectAssets m Coin
-> ExceptT ErrSelectAssets m Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ExceptT ErrSelectAssets m Coin
-> (ErrSelectAssets -> ExceptT ErrSelectAssets m Coin)
-> ExceptT ErrSelectAssets m Coin
forall (m :: * -> *) e a e'.
Monad m =>
ExceptT e m a -> (e -> ExceptT e' m a) -> ExceptT e' m a
`catchE` ErrSelectAssets -> ExceptT ErrSelectAssets m Coin
handleCannotCover)
  where
    -- Use method R-8 from to get top 90%.
    -- https://en.wikipedia.org/wiki/Quantile#Estimating_quantiles_from_a_sample
    deciles :: [Natural] -> FeeEstimation
deciles = [Word64] -> FeeEstimation
mkFeeEstimation
        ([Word64] -> FeeEstimation)
-> ([Natural] -> [Word64]) -> [Natural] -> FeeEstimation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Word64) -> [Double] -> [Word64]
forall a b. (a -> b) -> [a] -> [b]
map Double -> Word64
forall a b. (RealFrac a, Integral b) => a -> b
round
        ([Double] -> [Word64])
-> ([Natural] -> [Double]) -> [Natural] -> [Word64]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Double -> [Double]
forall a. Vector a -> [a]
V.toList
        (Vector Double -> [Double])
-> ([Natural] -> Vector Double) -> [Natural] -> [Double]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContParam -> Vector Int -> Int -> Vector Double -> Vector Double
forall (v :: * -> *) (f :: * -> *).
(Vector v Double, Foldable f, Functor f) =>
ContParam -> f Int -> Int -> v Double -> f Double
quantiles ContParam
medianUnbiased ([Int] -> Vector Int
forall a. [a] -> Vector a
V.fromList [Int
1, Int
10]) Int
10
        (Vector Double -> Vector Double)
-> ([Natural] -> Vector Double) -> [Natural] -> Vector Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Double] -> Vector Double
forall a. [a] -> Vector a
V.fromList
        ([Double] -> Vector Double)
-> ([Natural] -> [Double]) -> [Natural] -> Vector Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Natural -> Double) -> [Natural] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map Natural -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral
    mkFeeEstimation :: [Word64] -> FeeEstimation
mkFeeEstimation [Word64
a,Word64
b] = Word64 -> Word64 -> FeeEstimation
FeeEstimation Word64
a Word64
b
    mkFeeEstimation [Word64]
_ = String -> FeeEstimation
forall a. HasCallStack => String -> a
error String
"estimateFee: impossible"

    -- Remove failed coin selections from samples. Unless they all failed, in
    -- which case pass on the error.
    handleErrors :: m [Either err a] -> ExceptT err m [a]
    handleErrors :: m [Either err a] -> ExceptT err m [a]
handleErrors = m (Either err [a]) -> ExceptT err m [a]
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either err [a]) -> ExceptT err m [a])
-> (m [Either err a] -> m (Either err [a]))
-> m [Either err a]
-> ExceptT err m [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Either err a] -> Either err [a])
-> m [Either err a] -> m (Either err [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Either err a] -> Either err [a]
forall a b. [Either a b] -> Either a [b]
skipFailed
      where
        skipFailed :: [Either a b] -> Either a [b]
skipFailed [Either a b]
samples = case [Either a b] -> ([a], [b])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either a b]
samples of
            ([], []) ->
                String -> Either a [b]
forall a. HasCallStack => String -> a
error String
"estimateFee: impossible empty list"
            ((a
e:[a]
_), []) ->
                a -> Either a [b]
forall a b. a -> Either a b
Left a
e
            ([a]
_, [b]
samples') ->
                [b] -> Either a [b]
forall a b. b -> Either a b
Right [b]
samples'

    repeats :: Int
repeats = Int
100 -- TODO: modify repeats based on data

    -- | When estimating fee, it is rather cumbersome to return "cannot cover fee"
    -- if clients are just asking for an estimation. Therefore, we convert
    -- "cannot cover" errors into the necessary fee amount, even though there isn't
    -- enough in the wallet to cover for these fees.
    handleCannotCover :: ErrSelectAssets -> ExceptT ErrSelectAssets m Coin
    handleCannotCover :: ErrSelectAssets -> ExceptT ErrSelectAssets m Coin
handleCannotCover = \case
        e :: ErrSelectAssets
e@(ErrSelectAssetsSelectionError SelectionError WalletSelectionContext
se) -> case SelectionError WalletSelectionContext
se of
            SelectionBalanceErrorOf (UnableToConstructChange UnableToConstructChangeError
ce) ->
                case UnableToConstructChangeError
ce of
                    UnableToConstructChangeError {Coin
$sel:requiredCost:UnableToConstructChangeError :: UnableToConstructChangeError -> Coin
requiredCost :: Coin
requiredCost} ->
                        Coin -> ExceptT ErrSelectAssets m Coin
forall (f :: * -> *) a. Applicative f => a -> f a
pure Coin
requiredCost
            SelectionError WalletSelectionContext
_ ->
                ErrSelectAssets -> ExceptT ErrSelectAssets m Coin
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE  ErrSelectAssets
e
        ErrSelectAssets
e ->
            ErrSelectAssets -> ExceptT ErrSelectAssets m Coin
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ErrSelectAssets
e

{-------------------------------------------------------------------------------
                                  Key Store
-------------------------------------------------------------------------------}
-- | The password here undergoes PBKDF2 encryption using HMAC
-- with the hash algorithm SHA512 which is realized in encryptPassphrase
attachPrivateKeyFromPwdScheme
    :: forall ctx s k.
        ( HasDBLayer IO s k ctx
        )
    => ctx
    -> WalletId
    -> (k 'RootK XPrv, (PassphraseScheme, Passphrase "user"))
    -> ExceptT ErrNoSuchWallet IO ()
attachPrivateKeyFromPwdScheme :: ctx
-> WalletId
-> (k 'RootK XPrv, (PassphraseScheme, Passphrase "user"))
-> ExceptT ErrNoSuchWallet IO ()
attachPrivateKeyFromPwdScheme ctx
ctx WalletId
wid (k 'RootK XPrv
xprv, (PassphraseScheme
scheme, Passphrase "user"
pwd)) = DBLayer IO s k
db DBLayer IO s k
-> (DBLayer IO s k -> ExceptT ErrNoSuchWallet IO ())
-> ExceptT ErrNoSuchWallet IO ()
forall a b. a -> (a -> b) -> b
& \DBLayer IO s k
_ -> do
    PassphraseHash
hpwd <- IO PassphraseHash -> ExceptT ErrNoSuchWallet IO PassphraseHash
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO PassphraseHash -> ExceptT ErrNoSuchWallet IO PassphraseHash)
-> IO PassphraseHash -> ExceptT ErrNoSuchWallet IO PassphraseHash
forall a b. (a -> b) -> a -> b
$ PassphraseScheme -> Passphrase "user" -> IO PassphraseHash
forall (m :: * -> *).
MonadRandom m =>
PassphraseScheme -> Passphrase "user" -> m PassphraseHash
encryptPassphrase' PassphraseScheme
scheme Passphrase "user"
pwd
    -- NOTE Only new wallets are constructed through this function, so the
    -- passphrase is encrypted with the new scheme (i.e. PBKDF2)
    --
    -- We do an extra sanity check after having encrypted the passphrase: we
    -- tried to avoid some programmer mistakes with the phantom types on
    -- Passphrase, but it's still possible that someone would inadvertently call
    -- this function with a 'Passphrase' that wasn't prepared for
    -- 'EncryptWithPBKDF2', if this happens, this is a programmer error and we
    -- must fail hard for this would have dramatic effects later on.
    case PassphraseScheme
-> Passphrase "user"
-> PassphraseHash
-> Either ErrWrongPassphrase ()
checkPassphrase PassphraseScheme
scheme Passphrase "user"
pwd PassphraseHash
hpwd of
        Right () -> DBLayer IO s k
-> WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> PassphraseScheme
-> ExceptT ErrNoSuchWallet IO ()
forall s (k :: Depth -> * -> *).
DBLayer IO s k
-> WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> PassphraseScheme
-> ExceptT ErrNoSuchWallet IO ()
attachPrivateKey DBLayer IO s k
db WalletId
wid (k 'RootK XPrv
xprv, PassphraseHash
hpwd) PassphraseScheme
scheme
        Left{} -> String -> ExceptT ErrNoSuchWallet IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
            String
"Awe crap! The passphrase given to 'attachPrivateKeyFromPwd' wasn't \
            \rightfully constructed. This is a programmer error. Look for calls \
            \to this function and make sure that the given Passphrase wasn't not \
            \prepared using 'EncryptWithScrypt'!"
  where
    db :: DBLayer IO s k
db = ctx
ctx ctx
-> ((DBLayer IO s k -> Const (DBLayer IO s k) (DBLayer IO s k))
    -> ctx -> Const (DBLayer IO s k) ctx)
-> DBLayer IO s k
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx. HasDBLayer IO s k ctx => Lens' ctx (DBLayer IO s k)
forall (m :: * -> *) s (k :: Depth -> * -> *) ctx.
HasDBLayer m s k ctx =>
Lens' ctx (DBLayer m s k)
dbLayer @IO @s @k

attachPrivateKeyFromPwd
    :: forall ctx s k.
        ( HasDBLayer IO s k ctx
        )
    => ctx
    -> WalletId
    -> (k 'RootK XPrv, Passphrase "user")
    -> ExceptT ErrNoSuchWallet IO ()
attachPrivateKeyFromPwd :: ctx
-> WalletId
-> (k 'RootK XPrv, Passphrase "user")
-> ExceptT ErrNoSuchWallet IO ()
attachPrivateKeyFromPwd ctx
ctx WalletId
wid (k 'RootK XPrv
xprv, Passphrase "user"
pwd) =
    ctx
-> WalletId
-> (k 'RootK XPrv, (PassphraseScheme, Passphrase "user"))
-> ExceptT ErrNoSuchWallet IO ()
forall ctx s (k :: Depth -> * -> *).
HasDBLayer IO s k ctx =>
ctx
-> WalletId
-> (k 'RootK XPrv, (PassphraseScheme, Passphrase "user"))
-> ExceptT ErrNoSuchWallet IO ()
attachPrivateKeyFromPwdScheme @ctx @s @k ctx
ctx WalletId
wid
       (k 'RootK XPrv
xprv, (PassphraseScheme
currentPassphraseScheme, Passphrase "user"
pwd))

-- | The hash here is the output of Scrypt function with the following parameters:
-- - logN = 14
-- - r = 8
-- - p = 1
-- - bytesNumber = 64
attachPrivateKeyFromPwdHash
    :: forall ctx s k.
        ( HasDBLayer IO s k ctx
        )
    => ctx
    -> WalletId
    -> (k 'RootK XPrv, PassphraseHash)
    -> ExceptT ErrNoSuchWallet IO ()
attachPrivateKeyFromPwdHash :: ctx
-> WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet IO ()
attachPrivateKeyFromPwdHash ctx
ctx WalletId
wid (k 'RootK XPrv
xprv, PassphraseHash
hpwd) = DBLayer IO s k
db DBLayer IO s k
-> (DBLayer IO s k -> ExceptT ErrNoSuchWallet IO ())
-> ExceptT ErrNoSuchWallet IO ()
forall a b. a -> (a -> b) -> b
& \DBLayer IO s k
_ ->
    -- NOTE Only legacy wallets are imported through this function, passphrase
    -- were encrypted with the legacy scheme (Scrypt).
    DBLayer IO s k
-> WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> PassphraseScheme
-> ExceptT ErrNoSuchWallet IO ()
forall s (k :: Depth -> * -> *).
DBLayer IO s k
-> WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> PassphraseScheme
-> ExceptT ErrNoSuchWallet IO ()
attachPrivateKey DBLayer IO s k
db WalletId
wid (k 'RootK XPrv
xprv, PassphraseHash
hpwd) PassphraseScheme
EncryptWithScrypt
  where
    db :: DBLayer IO s k
db = ctx
ctx ctx
-> ((DBLayer IO s k -> Const (DBLayer IO s k) (DBLayer IO s k))
    -> ctx -> Const (DBLayer IO s k) ctx)
-> DBLayer IO s k
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx. HasDBLayer IO s k ctx => Lens' ctx (DBLayer IO s k)
forall (m :: * -> *) s (k :: Depth -> * -> *) ctx.
HasDBLayer m s k ctx =>
Lens' ctx (DBLayer m s k)
dbLayer @IO @s @k

attachPrivateKey
    :: DBLayer IO s k
    -> WalletId
    -> (k 'RootK XPrv, PassphraseHash)
    -> PassphraseScheme
    -> ExceptT ErrNoSuchWallet IO ()
attachPrivateKey :: DBLayer IO s k
-> WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> PassphraseScheme
-> ExceptT ErrNoSuchWallet IO ()
attachPrivateKey DBLayer IO s k
db WalletId
wid (k 'RootK XPrv
xprv, PassphraseHash
hpwd) PassphraseScheme
scheme = DBLayer IO s k
db DBLayer IO s k
-> (DBLayer IO s k -> ExceptT ErrNoSuchWallet IO ())
-> ExceptT ErrNoSuchWallet IO ()
forall a b. a -> (a -> b) -> b
& \DBLayer{stm [WalletId]
DBVar stm (DeltaMap WalletId (DeltaWalletState s))
WalletId -> stm [LocalTxSubmissionStatus SealedTx]
WalletId -> stm [ChainPoint]
WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
WalletId -> stm (Maybe GenesisParameters)
WalletId -> stm (Maybe WalletMetadata)
WalletId -> stm (Maybe (Wallet s))
WalletId -> stm Coin
WalletId -> ExceptT ErrNoSuchWallet stm Bool
WalletId -> ExceptT ErrNoSuchWallet stm ()
WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
forall a. stm a -> IO a
atomically :: forall a. stm a -> IO a
prune :: WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
rollbackTo :: WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
readGenesisParameters :: WalletId -> stm (Maybe GenesisParameters)
readPrivateKey :: WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
putPrivateKey :: WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
removePendingOrExpiredTx :: WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
updatePendingTxForExpiry :: WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
readLocalTxSubmissionPending :: WalletId -> stm [LocalTxSubmissionStatus SealedTx]
putLocalTxSubmission :: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
getTx :: WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
readTxHistory :: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
putTxHistory :: WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
readDelegationRewardBalance :: WalletId -> stm Coin
putDelegationRewardBalance :: WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
putDelegationCertificate :: WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
isStakeKeyRegistered :: WalletId -> ExceptT ErrNoSuchWallet stm Bool
readWalletMeta :: WalletId -> stm (Maybe WalletMetadata)
putWalletMeta :: WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
listCheckpoints :: WalletId -> stm [ChainPoint]
readCheckpoint :: WalletId -> stm (Maybe (Wallet s))
putCheckpoint :: WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
walletsDB :: DBVar stm (DeltaMap WalletId (DeltaWalletState s))
listWallets :: stm [WalletId]
removeWallet :: WalletId -> ExceptT ErrNoSuchWallet stm ()
initializeWallet :: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
atomically :: ()
prune :: ()
rollbackTo :: ()
readGenesisParameters :: ()
readPrivateKey :: ()
putPrivateKey :: ()
removePendingOrExpiredTx :: ()
updatePendingTxForExpiry :: ()
readLocalTxSubmissionPending :: ()
putLocalTxSubmission :: ()
getTx :: ()
readTxHistory :: ()
putTxHistory :: ()
readDelegationRewardBalance :: ()
putDelegationRewardBalance :: ()
putDelegationCertificate :: ()
isStakeKeyRegistered :: ()
readWalletMeta :: ()
putWalletMeta :: ()
listCheckpoints :: ()
readCheckpoint :: ()
putCheckpoint :: ()
walletsDB :: ()
listWallets :: ()
removeWallet :: ()
initializeWallet :: ()
..} -> do
    UTCTime
now <- IO UTCTime -> ExceptT ErrNoSuchWallet IO UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
    (stm (Either ErrNoSuchWallet ()) -> IO (Either ErrNoSuchWallet ()))
-> ExceptT ErrNoSuchWallet stm () -> ExceptT ErrNoSuchWallet IO ()
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT stm (Either ErrNoSuchWallet ()) -> IO (Either ErrNoSuchWallet ())
forall a. stm a -> IO a
atomically (ExceptT ErrNoSuchWallet stm () -> ExceptT ErrNoSuchWallet IO ())
-> ExceptT ErrNoSuchWallet stm () -> ExceptT ErrNoSuchWallet IO ()
forall a b. (a -> b) -> a -> b
$ do
        WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
putPrivateKey WalletId
wid (k 'RootK XPrv
xprv, PassphraseHash
hpwd)
        WalletMetadata
meta <- WalletId
-> stm (Maybe WalletMetadata)
-> ExceptT ErrNoSuchWallet stm WalletMetadata
forall (m :: * -> *) a.
Monad m =>
WalletId -> m (Maybe a) -> ExceptT ErrNoSuchWallet m a
withNoSuchWallet WalletId
wid (stm (Maybe WalletMetadata)
 -> ExceptT ErrNoSuchWallet stm WalletMetadata)
-> stm (Maybe WalletMetadata)
-> ExceptT ErrNoSuchWallet stm WalletMetadata
forall a b. (a -> b) -> a -> b
$ WalletId -> stm (Maybe WalletMetadata)
readWalletMeta WalletId
wid
        let modify :: WalletMetadata -> WalletMetadata
modify WalletMetadata
x = WalletMetadata
x
                { $sel:passphraseInfo:WalletMetadata :: Maybe WalletPassphraseInfo
passphraseInfo = WalletPassphraseInfo -> Maybe WalletPassphraseInfo
forall a. a -> Maybe a
Just (WalletPassphraseInfo -> Maybe WalletPassphraseInfo)
-> WalletPassphraseInfo -> Maybe WalletPassphraseInfo
forall a b. (a -> b) -> a -> b
$ WalletPassphraseInfo :: UTCTime -> PassphraseScheme -> WalletPassphraseInfo
WalletPassphraseInfo
                    { lastUpdatedAt :: UTCTime
lastUpdatedAt = UTCTime
now
                    , passphraseScheme :: PassphraseScheme
passphraseScheme = PassphraseScheme
scheme
                    }
                }
        WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
putWalletMeta WalletId
wid (WalletMetadata -> WalletMetadata
modify WalletMetadata
meta)

-- | Execute an action which requires holding a root XPrv.
--
-- 'withRootKey' takes a callback function with two arguments:
--
--  - The encrypted root private key itself
--  - The underlying passphrase scheme (legacy or new)
--
-- Caller are then expected to use 'preparePassphrase' with the given scheme in
-- order to "prepare" the passphrase to be used by other function. This does
-- nothing for the new encryption, but for the legacy encryption with Scrypt,
-- passphrases needed to first be CBOR serialized and blake2b_256 hashed.
--
-- @@@
--     withRootKey @ctx @s @k ctx wid pwd OnError $ \xprv scheme ->
--         changePassphrase (preparePassphrase scheme pwd) newPwd xprv
-- @@@
withRootKey
    :: forall ctx s k e a. HasDBLayer IO s k ctx
    => ctx
    -> WalletId
    -> Passphrase "user"
    -> (ErrWithRootKey -> e)
    -> (k 'RootK XPrv -> PassphraseScheme -> ExceptT e IO a)
    -> ExceptT e IO a
withRootKey :: ctx
-> WalletId
-> Passphrase "user"
-> (ErrWithRootKey -> e)
-> (k 'RootK XPrv -> PassphraseScheme -> ExceptT e IO a)
-> ExceptT e IO a
withRootKey ctx
ctx WalletId
wid Passphrase "user"
pwd ErrWithRootKey -> e
embed k 'RootK XPrv -> PassphraseScheme -> ExceptT e IO a
action = DBLayer IO s k
db DBLayer IO s k
-> (DBLayer IO s k -> ExceptT e IO a) -> ExceptT e IO a
forall a b. a -> (a -> b) -> b
& \DBLayer{stm [WalletId]
DBVar stm (DeltaMap WalletId (DeltaWalletState s))
WalletId -> stm [LocalTxSubmissionStatus SealedTx]
WalletId -> stm [ChainPoint]
WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
WalletId -> stm (Maybe GenesisParameters)
WalletId -> stm (Maybe WalletMetadata)
WalletId -> stm (Maybe (Wallet s))
WalletId -> stm Coin
WalletId -> ExceptT ErrNoSuchWallet stm Bool
WalletId -> ExceptT ErrNoSuchWallet stm ()
WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
forall a. stm a -> IO a
atomically :: forall a. stm a -> IO a
prune :: WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
rollbackTo :: WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
readGenesisParameters :: WalletId -> stm (Maybe GenesisParameters)
readPrivateKey :: WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
putPrivateKey :: WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
removePendingOrExpiredTx :: WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
updatePendingTxForExpiry :: WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
readLocalTxSubmissionPending :: WalletId -> stm [LocalTxSubmissionStatus SealedTx]
putLocalTxSubmission :: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
getTx :: WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
readTxHistory :: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
putTxHistory :: WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
readDelegationRewardBalance :: WalletId -> stm Coin
putDelegationRewardBalance :: WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
putDelegationCertificate :: WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
isStakeKeyRegistered :: WalletId -> ExceptT ErrNoSuchWallet stm Bool
readWalletMeta :: WalletId -> stm (Maybe WalletMetadata)
putWalletMeta :: WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
listCheckpoints :: WalletId -> stm [ChainPoint]
readCheckpoint :: WalletId -> stm (Maybe (Wallet s))
putCheckpoint :: WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
walletsDB :: DBVar stm (DeltaMap WalletId (DeltaWalletState s))
listWallets :: stm [WalletId]
removeWallet :: WalletId -> ExceptT ErrNoSuchWallet stm ()
initializeWallet :: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
atomically :: ()
prune :: ()
rollbackTo :: ()
readGenesisParameters :: ()
readPrivateKey :: ()
putPrivateKey :: ()
removePendingOrExpiredTx :: ()
updatePendingTxForExpiry :: ()
readLocalTxSubmissionPending :: ()
putLocalTxSubmission :: ()
getTx :: ()
readTxHistory :: ()
putTxHistory :: ()
readDelegationRewardBalance :: ()
putDelegationRewardBalance :: ()
putDelegationCertificate :: ()
isStakeKeyRegistered :: ()
readWalletMeta :: ()
putWalletMeta :: ()
listCheckpoints :: ()
readCheckpoint :: ()
putCheckpoint :: ()
walletsDB :: ()
listWallets :: ()
removeWallet :: ()
initializeWallet :: ()
..} -> do
    (k 'RootK XPrv
xprv, PassphraseScheme
scheme) <- (ErrWithRootKey -> e)
-> ExceptT ErrWithRootKey IO (k 'RootK XPrv, PassphraseScheme)
-> ExceptT e IO (k 'RootK XPrv, PassphraseScheme)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ErrWithRootKey -> e
embed (ExceptT ErrWithRootKey IO (k 'RootK XPrv, PassphraseScheme)
 -> ExceptT e IO (k 'RootK XPrv, PassphraseScheme))
-> ExceptT ErrWithRootKey IO (k 'RootK XPrv, PassphraseScheme)
-> ExceptT e IO (k 'RootK XPrv, PassphraseScheme)
forall a b. (a -> b) -> a -> b
$ (stm (Either ErrWithRootKey (k 'RootK XPrv, PassphraseScheme))
 -> IO (Either ErrWithRootKey (k 'RootK XPrv, PassphraseScheme)))
-> ExceptT ErrWithRootKey stm (k 'RootK XPrv, PassphraseScheme)
-> ExceptT ErrWithRootKey IO (k 'RootK XPrv, PassphraseScheme)
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT stm (Either ErrWithRootKey (k 'RootK XPrv, PassphraseScheme))
-> IO (Either ErrWithRootKey (k 'RootK XPrv, PassphraseScheme))
forall a. stm a -> IO a
atomically (ExceptT ErrWithRootKey stm (k 'RootK XPrv, PassphraseScheme)
 -> ExceptT ErrWithRootKey IO (k 'RootK XPrv, PassphraseScheme))
-> ExceptT ErrWithRootKey stm (k 'RootK XPrv, PassphraseScheme)
-> ExceptT ErrWithRootKey IO (k 'RootK XPrv, PassphraseScheme)
forall a b. (a -> b) -> a -> b
$ do
        Maybe PassphraseScheme
mScheme <- (Maybe WalletMetadata
-> (WalletMetadata -> Maybe PassphraseScheme)
-> Maybe PassphraseScheme
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((WalletPassphraseInfo -> PassphraseScheme)
-> Maybe WalletPassphraseInfo -> Maybe PassphraseScheme
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap WalletPassphraseInfo -> PassphraseScheme
passphraseScheme (Maybe WalletPassphraseInfo -> Maybe PassphraseScheme)
-> (WalletMetadata -> Maybe WalletPassphraseInfo)
-> WalletMetadata
-> Maybe PassphraseScheme
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WalletMetadata -> Maybe WalletPassphraseInfo
passphraseInfo)) (Maybe WalletMetadata -> Maybe PassphraseScheme)
-> ExceptT ErrWithRootKey stm (Maybe WalletMetadata)
-> ExceptT ErrWithRootKey stm (Maybe PassphraseScheme)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            stm (Maybe WalletMetadata)
-> ExceptT ErrWithRootKey stm (Maybe WalletMetadata)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WalletId -> stm (Maybe WalletMetadata)
readWalletMeta WalletId
wid)
        Maybe (k 'RootK XPrv, PassphraseHash)
mXPrv <- stm (Maybe (k 'RootK XPrv, PassphraseHash))
-> ExceptT
     ErrWithRootKey stm (Maybe (k 'RootK XPrv, PassphraseHash))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (stm (Maybe (k 'RootK XPrv, PassphraseHash))
 -> ExceptT
      ErrWithRootKey stm (Maybe (k 'RootK XPrv, PassphraseHash)))
-> stm (Maybe (k 'RootK XPrv, PassphraseHash))
-> ExceptT
     ErrWithRootKey stm (Maybe (k 'RootK XPrv, PassphraseHash))
forall a b. (a -> b) -> a -> b
$ WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
readPrivateKey WalletId
wid
        case (Maybe (k 'RootK XPrv, PassphraseHash)
mXPrv, Maybe PassphraseScheme
mScheme) of
            (Just (k 'RootK XPrv
xprv, PassphraseHash
hpwd), Just PassphraseScheme
scheme) -> do
                (ErrWrongPassphrase -> ErrWithRootKey)
-> ExceptT ErrWrongPassphrase stm ()
-> ExceptT ErrWithRootKey stm ()
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (WalletId -> ErrWrongPassphrase -> ErrWithRootKey
ErrWithRootKeyWrongPassphrase WalletId
wid) (ExceptT ErrWrongPassphrase stm ()
 -> ExceptT ErrWithRootKey stm ())
-> ExceptT ErrWrongPassphrase stm ()
-> ExceptT ErrWithRootKey stm ()
forall a b. (a -> b) -> a -> b
$ stm (Either ErrWrongPassphrase ())
-> ExceptT ErrWrongPassphrase stm ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (stm (Either ErrWrongPassphrase ())
 -> ExceptT ErrWrongPassphrase stm ())
-> stm (Either ErrWrongPassphrase ())
-> ExceptT ErrWrongPassphrase stm ()
forall a b. (a -> b) -> a -> b
$
                    Either ErrWrongPassphrase () -> stm (Either ErrWrongPassphrase ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ErrWrongPassphrase ()
 -> stm (Either ErrWrongPassphrase ()))
-> Either ErrWrongPassphrase ()
-> stm (Either ErrWrongPassphrase ())
forall a b. (a -> b) -> a -> b
$ PassphraseScheme
-> Passphrase "user"
-> PassphraseHash
-> Either ErrWrongPassphrase ()
checkPassphrase PassphraseScheme
scheme Passphrase "user"
pwd PassphraseHash
hpwd
                (k 'RootK XPrv, PassphraseScheme)
-> ExceptT ErrWithRootKey stm (k 'RootK XPrv, PassphraseScheme)
forall (m :: * -> *) a. Monad m => a -> m a
return (k 'RootK XPrv
xprv, PassphraseScheme
scheme)
            (Maybe (k 'RootK XPrv, PassphraseHash), Maybe PassphraseScheme)
_ ->
                ErrWithRootKey
-> ExceptT ErrWithRootKey stm (k 'RootK XPrv, PassphraseScheme)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (ErrWithRootKey
 -> ExceptT ErrWithRootKey stm (k 'RootK XPrv, PassphraseScheme))
-> ErrWithRootKey
-> ExceptT ErrWithRootKey stm (k 'RootK XPrv, PassphraseScheme)
forall a b. (a -> b) -> a -> b
$ WalletId -> ErrWithRootKey
ErrWithRootKeyNoRootKey WalletId
wid
    k 'RootK XPrv -> PassphraseScheme -> ExceptT e IO a
action k 'RootK XPrv
xprv PassphraseScheme
scheme
  where
    db :: DBLayer IO s k
db = ctx
ctx ctx
-> ((DBLayer IO s k -> Const (DBLayer IO s k) (DBLayer IO s k))
    -> ctx -> Const (DBLayer IO s k) ctx)
-> DBLayer IO s k
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx. HasDBLayer IO s k ctx => Lens' ctx (DBLayer IO s k)
forall (m :: * -> *) s (k :: Depth -> * -> *) ctx.
HasDBLayer m s k ctx =>
Lens' ctx (DBLayer m s k)
dbLayer @IO @s @k

-- | Sign an arbitrary transaction metadata object with a private key belonging
-- to the wallet's account.
--
-- This is experimental, and will likely be replaced by a more robust to
-- arbitrary message signing using COSE, or a subset of it.
signMetadataWith
    :: forall ctx s k n.
        ( HasDBLayer IO s k ctx
        , HardDerivation k
        , AddressIndexDerivationType k ~ 'Soft
        , WalletKey k
        , s ~ SeqState n k
        )
    => ctx
    -> WalletId
    -> Passphrase "user"
    -> (Role, DerivationIndex)
    -> TxMetadata
    -> ExceptT ErrSignMetadataWith IO (Signature TxMetadata)
signMetadataWith :: ctx
-> WalletId
-> Passphrase "user"
-> (Role, DerivationIndex)
-> TxMetadata
-> ExceptT ErrSignMetadataWith IO (Signature TxMetadata)
signMetadataWith ctx
ctx WalletId
wid Passphrase "user"
pwd (Role
role_, DerivationIndex
ix) TxMetadata
metadata = DBLayer IO s k
db DBLayer IO s k
-> (DBLayer IO s k
    -> ExceptT ErrSignMetadataWith IO (Signature TxMetadata))
-> ExceptT ErrSignMetadataWith IO (Signature TxMetadata)
forall a b. a -> (a -> b) -> b
& \DBLayer{stm [WalletId]
DBVar stm (DeltaMap WalletId (DeltaWalletState s))
WalletId -> stm [LocalTxSubmissionStatus SealedTx]
WalletId -> stm [ChainPoint]
WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
WalletId -> stm (Maybe GenesisParameters)
WalletId -> stm (Maybe WalletMetadata)
WalletId -> stm (Maybe (Wallet s))
WalletId -> stm Coin
WalletId -> ExceptT ErrNoSuchWallet stm Bool
WalletId -> ExceptT ErrNoSuchWallet stm ()
WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
forall a. stm a -> IO a
atomically :: forall a. stm a -> IO a
prune :: WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
rollbackTo :: WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
readGenesisParameters :: WalletId -> stm (Maybe GenesisParameters)
readPrivateKey :: WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
putPrivateKey :: WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
removePendingOrExpiredTx :: WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
updatePendingTxForExpiry :: WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
readLocalTxSubmissionPending :: WalletId -> stm [LocalTxSubmissionStatus SealedTx]
putLocalTxSubmission :: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
getTx :: WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
readTxHistory :: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
putTxHistory :: WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
readDelegationRewardBalance :: WalletId -> stm Coin
putDelegationRewardBalance :: WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
putDelegationCertificate :: WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
isStakeKeyRegistered :: WalletId -> ExceptT ErrNoSuchWallet stm Bool
readWalletMeta :: WalletId -> stm (Maybe WalletMetadata)
putWalletMeta :: WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
listCheckpoints :: WalletId -> stm [ChainPoint]
readCheckpoint :: WalletId -> stm (Maybe (Wallet s))
putCheckpoint :: WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
walletsDB :: DBVar stm (DeltaMap WalletId (DeltaWalletState s))
listWallets :: stm [WalletId]
removeWallet :: WalletId -> ExceptT ErrNoSuchWallet stm ()
initializeWallet :: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
atomically :: ()
prune :: ()
rollbackTo :: ()
readGenesisParameters :: ()
readPrivateKey :: ()
putPrivateKey :: ()
removePendingOrExpiredTx :: ()
updatePendingTxForExpiry :: ()
readLocalTxSubmissionPending :: ()
putLocalTxSubmission :: ()
getTx :: ()
readTxHistory :: ()
putTxHistory :: ()
readDelegationRewardBalance :: ()
putDelegationRewardBalance :: ()
putDelegationCertificate :: ()
isStakeKeyRegistered :: ()
readWalletMeta :: ()
putWalletMeta :: ()
listCheckpoints :: ()
readCheckpoint :: ()
putCheckpoint :: ()
walletsDB :: ()
listWallets :: ()
removeWallet :: ()
initializeWallet :: ()
..} -> do
    Index 'Soft 'AddressK
addrIx <- (ErrInvalidDerivationIndex 'Soft 'AddressK -> ErrSignMetadataWith)
-> ExceptT
     (ErrInvalidDerivationIndex 'Soft 'AddressK)
     IO
     (Index 'Soft 'AddressK)
-> ExceptT ErrSignMetadataWith IO (Index 'Soft 'AddressK)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ErrInvalidDerivationIndex 'Soft 'AddressK -> ErrSignMetadataWith
ErrSignMetadataWithInvalidIndex (ExceptT
   (ErrInvalidDerivationIndex 'Soft 'AddressK)
   IO
   (Index 'Soft 'AddressK)
 -> ExceptT ErrSignMetadataWith IO (Index 'Soft 'AddressK))
-> ExceptT
     (ErrInvalidDerivationIndex 'Soft 'AddressK)
     IO
     (Index 'Soft 'AddressK)
-> ExceptT ErrSignMetadataWith IO (Index 'Soft 'AddressK)
forall a b. (a -> b) -> a -> b
$ DerivationIndex
-> ExceptT
     (ErrInvalidDerivationIndex 'Soft 'AddressK)
     IO
     (Index 'Soft 'AddressK)
forall (m :: * -> *) (whatever :: Depth).
Monad m =>
DerivationIndex
-> ExceptT
     (ErrInvalidDerivationIndex 'Soft 'AddressK)
     m
     (Index 'Soft whatever)
guardSoftIndex DerivationIndex
ix

    Wallet s
cp <- (stm (Either ErrSignMetadataWith (Wallet s))
 -> IO (Either ErrSignMetadataWith (Wallet s)))
-> ExceptT ErrSignMetadataWith stm (Wallet s)
-> ExceptT ErrSignMetadataWith IO (Wallet s)
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT stm (Either ErrSignMetadataWith (Wallet s))
-> IO (Either ErrSignMetadataWith (Wallet s))
forall a. stm a -> IO a
atomically
        (ExceptT ErrSignMetadataWith stm (Wallet s)
 -> ExceptT ErrSignMetadataWith IO (Wallet s))
-> ExceptT ErrSignMetadataWith stm (Wallet s)
-> ExceptT ErrSignMetadataWith IO (Wallet s)
forall a b. (a -> b) -> a -> b
$ (ErrNoSuchWallet -> ErrSignMetadataWith)
-> ExceptT ErrNoSuchWallet stm (Wallet s)
-> ExceptT ErrSignMetadataWith stm (Wallet s)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ErrNoSuchWallet -> ErrSignMetadataWith
ErrSignMetadataWithNoSuchWallet
        (ExceptT ErrNoSuchWallet stm (Wallet s)
 -> ExceptT ErrSignMetadataWith stm (Wallet s))
-> ExceptT ErrNoSuchWallet stm (Wallet s)
-> ExceptT ErrSignMetadataWith stm (Wallet s)
forall a b. (a -> b) -> a -> b
$ WalletId
-> stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s)
forall (m :: * -> *) a.
Monad m =>
WalletId -> m (Maybe a) -> ExceptT ErrNoSuchWallet m a
withNoSuchWallet WalletId
wid
        (stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s))
-> stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s)
forall a b. (a -> b) -> a -> b
$ WalletId -> stm (Maybe (Wallet s))
readCheckpoint WalletId
wid

    ctx
-> WalletId
-> Passphrase "user"
-> (ErrWithRootKey -> ErrSignMetadataWith)
-> (k 'RootK XPrv
    -> PassphraseScheme
    -> ExceptT ErrSignMetadataWith IO (Signature TxMetadata))
-> ExceptT ErrSignMetadataWith IO (Signature TxMetadata)
forall ctx s (k :: Depth -> * -> *) e a.
HasDBLayer IO s k ctx =>
ctx
-> WalletId
-> Passphrase "user"
-> (ErrWithRootKey -> e)
-> (k 'RootK XPrv -> PassphraseScheme -> ExceptT e IO a)
-> ExceptT e IO a
withRootKey @ctx @s @k ctx
ctx WalletId
wid Passphrase "user"
pwd ErrWithRootKey -> ErrSignMetadataWith
ErrSignMetadataWithRootKey
        ((k 'RootK XPrv
  -> PassphraseScheme
  -> ExceptT ErrSignMetadataWith IO (Signature TxMetadata))
 -> ExceptT ErrSignMetadataWith IO (Signature TxMetadata))
-> (k 'RootK XPrv
    -> PassphraseScheme
    -> ExceptT ErrSignMetadataWith IO (Signature TxMetadata))
-> ExceptT ErrSignMetadataWith IO (Signature TxMetadata)
forall a b. (a -> b) -> a -> b
$ \k 'RootK XPrv
rootK PassphraseScheme
scheme -> do
            let encPwd :: Passphrase "encryption"
encPwd = PassphraseScheme -> Passphrase "user" -> Passphrase "encryption"
preparePassphrase PassphraseScheme
scheme Passphrase "user"
pwd
            let DerivationPrefix (Index 'Hardened 'PurposeK
_, Index 'Hardened 'CoinTypeK
_, Index 'Hardened 'AccountK
acctIx) = SeqState n k -> DerivationPrefix
forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
SeqState n k -> DerivationPrefix
Seq.derivationPrefix (Wallet s -> s
forall s. Wallet s -> s
getState Wallet s
cp)
            let acctK :: k 'AccountK XPrv
acctK = Passphrase "encryption"
-> k 'RootK XPrv -> Index 'Hardened 'AccountK -> k 'AccountK XPrv
forall (key :: Depth -> * -> *).
HardDerivation key =>
Passphrase "encryption"
-> key 'RootK XPrv
-> Index 'Hardened 'AccountK
-> key 'AccountK XPrv
deriveAccountPrivateKey Passphrase "encryption"
encPwd k 'RootK XPrv
rootK Index 'Hardened 'AccountK
acctIx
            let addrK :: k 'AddressK XPrv
addrK = Passphrase "encryption"
-> k 'AccountK XPrv
-> Role
-> Index (AddressIndexDerivationType k) 'AddressK
-> k 'AddressK XPrv
forall (key :: Depth -> * -> *).
HardDerivation key =>
Passphrase "encryption"
-> key 'AccountK XPrv
-> Role
-> Index (AddressIndexDerivationType key) 'AddressK
-> key 'AddressK XPrv
deriveAddressPrivateKey Passphrase "encryption"
encPwd k 'AccountK XPrv
acctK Role
role_ Index (AddressIndexDerivationType k) 'AddressK
Index 'Soft 'AddressK
addrIx
            Signature TxMetadata
-> ExceptT ErrSignMetadataWith IO (Signature TxMetadata)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Signature TxMetadata
 -> ExceptT ErrSignMetadataWith IO (Signature TxMetadata))
-> Signature TxMetadata
-> ExceptT ErrSignMetadataWith IO (Signature TxMetadata)
forall a b. (a -> b) -> a -> b
$
                ByteString -> Signature TxMetadata
forall what. ByteString -> Signature what
Signature (ByteString -> Signature TxMetadata)
-> ByteString -> Signature TxMetadata
forall a b. (a -> b) -> a -> b
$ XSignature -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (XSignature -> ByteString) -> XSignature -> ByteString
forall a b. (a -> b) -> a -> b
$
                Passphrase "encryption" -> XPrv -> Digest Blake2b_256 -> XSignature
forall passPhrase msg.
(ByteArrayAccess passPhrase, ByteArrayAccess msg) =>
passPhrase -> XPrv -> msg -> XSignature
CC.sign Passphrase "encryption"
encPwd (k 'AddressK XPrv -> XPrv
forall (key :: Depth -> * -> *) (depth :: Depth) raw.
WalletKey key =>
key depth raw -> raw
getRawKey k 'AddressK XPrv
addrK) (Digest Blake2b_256 -> XSignature)
-> Digest Blake2b_256 -> XSignature
forall a b. (a -> b) -> a -> b
$
                (ByteArrayAccess ByteString, HashAlgorithm Blake2b_256) =>
ByteString -> Digest Blake2b_256
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
hash @ByteString @Blake2b_256 (ByteString -> Digest Blake2b_256)
-> ByteString -> Digest Blake2b_256
forall a b. (a -> b) -> a -> b
$
                TxMetadata -> ByteString
forall a. SerialiseAsCBOR a => a -> ByteString
serialiseToCBOR TxMetadata
metadata
  where
    db :: DBLayer IO s k
db = ctx
ctx ctx
-> ((DBLayer IO s k -> Const (DBLayer IO s k) (DBLayer IO s k))
    -> ctx -> Const (DBLayer IO s k) ctx)
-> DBLayer IO s k
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx. HasDBLayer IO s k ctx => Lens' ctx (DBLayer IO s k)
forall (m :: * -> *) s (k :: Depth -> * -> *) ctx.
HasDBLayer m s k ctx =>
Lens' ctx (DBLayer m s k)
dbLayer @IO @s @k

derivePublicKey
    :: forall ctx s k.
        ( HasDBLayer IO s k ctx
        , SoftDerivation k
        , GetAccount s k
        )
    => ctx
    -> WalletId
    -> Role
    -> DerivationIndex
    -> ExceptT ErrDerivePublicKey IO (k 'AddressK XPub)
derivePublicKey :: ctx
-> WalletId
-> Role
-> DerivationIndex
-> ExceptT ErrDerivePublicKey IO (k 'AddressK XPub)
derivePublicKey ctx
ctx WalletId
wid Role
role_ DerivationIndex
ix = DBLayer IO s k
db DBLayer IO s k
-> (DBLayer IO s k
    -> ExceptT ErrDerivePublicKey IO (k 'AddressK XPub))
-> ExceptT ErrDerivePublicKey IO (k 'AddressK XPub)
forall a b. a -> (a -> b) -> b
& \DBLayer{stm [WalletId]
DBVar stm (DeltaMap WalletId (DeltaWalletState s))
WalletId -> stm [LocalTxSubmissionStatus SealedTx]
WalletId -> stm [ChainPoint]
WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
WalletId -> stm (Maybe GenesisParameters)
WalletId -> stm (Maybe WalletMetadata)
WalletId -> stm (Maybe (Wallet s))
WalletId -> stm Coin
WalletId -> ExceptT ErrNoSuchWallet stm Bool
WalletId -> ExceptT ErrNoSuchWallet stm ()
WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
forall a. stm a -> IO a
atomically :: forall a. stm a -> IO a
prune :: WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
rollbackTo :: WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
readGenesisParameters :: WalletId -> stm (Maybe GenesisParameters)
readPrivateKey :: WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
putPrivateKey :: WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
removePendingOrExpiredTx :: WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
updatePendingTxForExpiry :: WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
readLocalTxSubmissionPending :: WalletId -> stm [LocalTxSubmissionStatus SealedTx]
putLocalTxSubmission :: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
getTx :: WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
readTxHistory :: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
putTxHistory :: WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
readDelegationRewardBalance :: WalletId -> stm Coin
putDelegationRewardBalance :: WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
putDelegationCertificate :: WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
isStakeKeyRegistered :: WalletId -> ExceptT ErrNoSuchWallet stm Bool
readWalletMeta :: WalletId -> stm (Maybe WalletMetadata)
putWalletMeta :: WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
listCheckpoints :: WalletId -> stm [ChainPoint]
readCheckpoint :: WalletId -> stm (Maybe (Wallet s))
putCheckpoint :: WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
walletsDB :: DBVar stm (DeltaMap WalletId (DeltaWalletState s))
listWallets :: stm [WalletId]
removeWallet :: WalletId -> ExceptT ErrNoSuchWallet stm ()
initializeWallet :: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
atomically :: ()
prune :: ()
rollbackTo :: ()
readGenesisParameters :: ()
readPrivateKey :: ()
putPrivateKey :: ()
removePendingOrExpiredTx :: ()
updatePendingTxForExpiry :: ()
readLocalTxSubmissionPending :: ()
putLocalTxSubmission :: ()
getTx :: ()
readTxHistory :: ()
putTxHistory :: ()
readDelegationRewardBalance :: ()
putDelegationRewardBalance :: ()
putDelegationCertificate :: ()
isStakeKeyRegistered :: ()
readWalletMeta :: ()
putWalletMeta :: ()
listCheckpoints :: ()
readCheckpoint :: ()
putCheckpoint :: ()
walletsDB :: ()
listWallets :: ()
removeWallet :: ()
initializeWallet :: ()
..} -> do
    Index 'Soft 'AddressK
addrIx <- (ErrInvalidDerivationIndex 'Soft 'AddressK -> ErrDerivePublicKey)
-> ExceptT
     (ErrInvalidDerivationIndex 'Soft 'AddressK)
     IO
     (Index 'Soft 'AddressK)
-> ExceptT ErrDerivePublicKey IO (Index 'Soft 'AddressK)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ErrInvalidDerivationIndex 'Soft 'AddressK -> ErrDerivePublicKey
ErrDerivePublicKeyInvalidIndex (ExceptT
   (ErrInvalidDerivationIndex 'Soft 'AddressK)
   IO
   (Index 'Soft 'AddressK)
 -> ExceptT ErrDerivePublicKey IO (Index 'Soft 'AddressK))
-> ExceptT
     (ErrInvalidDerivationIndex 'Soft 'AddressK)
     IO
     (Index 'Soft 'AddressK)
-> ExceptT ErrDerivePublicKey IO (Index 'Soft 'AddressK)
forall a b. (a -> b) -> a -> b
$ DerivationIndex
-> ExceptT
     (ErrInvalidDerivationIndex 'Soft 'AddressK)
     IO
     (Index 'Soft 'AddressK)
forall (m :: * -> *) (whatever :: Depth).
Monad m =>
DerivationIndex
-> ExceptT
     (ErrInvalidDerivationIndex 'Soft 'AddressK)
     m
     (Index 'Soft whatever)
guardSoftIndex DerivationIndex
ix

    Wallet s
cp <- (stm (Either ErrDerivePublicKey (Wallet s))
 -> IO (Either ErrDerivePublicKey (Wallet s)))
-> ExceptT ErrDerivePublicKey stm (Wallet s)
-> ExceptT ErrDerivePublicKey IO (Wallet s)
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT stm (Either ErrDerivePublicKey (Wallet s))
-> IO (Either ErrDerivePublicKey (Wallet s))
forall a. stm a -> IO a
atomically
        (ExceptT ErrDerivePublicKey stm (Wallet s)
 -> ExceptT ErrDerivePublicKey IO (Wallet s))
-> ExceptT ErrDerivePublicKey stm (Wallet s)
-> ExceptT ErrDerivePublicKey IO (Wallet s)
forall a b. (a -> b) -> a -> b
$ (ErrNoSuchWallet -> ErrDerivePublicKey)
-> ExceptT ErrNoSuchWallet stm (Wallet s)
-> ExceptT ErrDerivePublicKey stm (Wallet s)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ErrNoSuchWallet -> ErrDerivePublicKey
ErrDerivePublicKeyNoSuchWallet
        (ExceptT ErrNoSuchWallet stm (Wallet s)
 -> ExceptT ErrDerivePublicKey stm (Wallet s))
-> ExceptT ErrNoSuchWallet stm (Wallet s)
-> ExceptT ErrDerivePublicKey stm (Wallet s)
forall a b. (a -> b) -> a -> b
$ WalletId
-> stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s)
forall (m :: * -> *) a.
Monad m =>
WalletId -> m (Maybe a) -> ExceptT ErrNoSuchWallet m a
withNoSuchWallet WalletId
wid
        (stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s))
-> stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s)
forall a b. (a -> b) -> a -> b
$ WalletId -> stm (Maybe (Wallet s))
readCheckpoint WalletId
wid

    let acctK :: k 'AccountK XPub
acctK = s -> k 'AccountK XPub
forall s (key :: Depth -> * -> *).
GetAccount s key =>
s -> key 'AccountK XPub
getAccount (s -> k 'AccountK XPub) -> s -> k 'AccountK XPub
forall a b. (a -> b) -> a -> b
$ Wallet s -> s
forall s. Wallet s -> s
getState Wallet s
cp
    let addrK :: k 'AddressK XPub
addrK = k 'AccountK XPub
-> Role -> Index 'Soft 'AddressK -> k 'AddressK XPub
forall (key :: Depth -> * -> *).
SoftDerivation key =>
key 'AccountK XPub
-> Role -> Index 'Soft 'AddressK -> key 'AddressK XPub
deriveAddressPublicKey k 'AccountK XPub
acctK Role
role_ Index 'Soft 'AddressK
addrIx

    k 'AddressK XPub
-> ExceptT ErrDerivePublicKey IO (k 'AddressK XPub)
forall (m :: * -> *) a. Monad m => a -> m a
return k 'AddressK XPub
addrK
  where
    db :: DBLayer IO s k
db = ctx
ctx ctx
-> ((DBLayer IO s k -> Const (DBLayer IO s k) (DBLayer IO s k))
    -> ctx -> Const (DBLayer IO s k) ctx)
-> DBLayer IO s k
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx. HasDBLayer IO s k ctx => Lens' ctx (DBLayer IO s k)
forall (m :: * -> *) s (k :: Depth -> * -> *) ctx.
HasDBLayer m s k ctx =>
Lens' ctx (DBLayer m s k)
dbLayer @IO @s @k

-- | Retrieve current public account key of a wallet.
readAccountPublicKey
    :: forall ctx s k.
        ( HasDBLayer IO s k ctx
        , GetAccount s k
        )
    => ctx
    -> WalletId
    -> ExceptT ErrReadAccountPublicKey IO (k 'AccountK XPub)
readAccountPublicKey :: ctx
-> WalletId
-> ExceptT ErrReadAccountPublicKey IO (k 'AccountK XPub)
readAccountPublicKey ctx
ctx WalletId
wid = DBLayer IO s k
db DBLayer IO s k
-> (DBLayer IO s k
    -> ExceptT ErrReadAccountPublicKey IO (k 'AccountK XPub))
-> ExceptT ErrReadAccountPublicKey IO (k 'AccountK XPub)
forall a b. a -> (a -> b) -> b
& \DBLayer{stm [WalletId]
DBVar stm (DeltaMap WalletId (DeltaWalletState s))
WalletId -> stm [LocalTxSubmissionStatus SealedTx]
WalletId -> stm [ChainPoint]
WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
WalletId -> stm (Maybe GenesisParameters)
WalletId -> stm (Maybe WalletMetadata)
WalletId -> stm (Maybe (Wallet s))
WalletId -> stm Coin
WalletId -> ExceptT ErrNoSuchWallet stm Bool
WalletId -> ExceptT ErrNoSuchWallet stm ()
WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
forall a. stm a -> IO a
atomically :: forall a. stm a -> IO a
prune :: WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
rollbackTo :: WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
readGenesisParameters :: WalletId -> stm (Maybe GenesisParameters)
readPrivateKey :: WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
putPrivateKey :: WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
removePendingOrExpiredTx :: WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
updatePendingTxForExpiry :: WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
readLocalTxSubmissionPending :: WalletId -> stm [LocalTxSubmissionStatus SealedTx]
putLocalTxSubmission :: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
getTx :: WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
readTxHistory :: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
putTxHistory :: WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
readDelegationRewardBalance :: WalletId -> stm Coin
putDelegationRewardBalance :: WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
putDelegationCertificate :: WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
isStakeKeyRegistered :: WalletId -> ExceptT ErrNoSuchWallet stm Bool
readWalletMeta :: WalletId -> stm (Maybe WalletMetadata)
putWalletMeta :: WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
listCheckpoints :: WalletId -> stm [ChainPoint]
readCheckpoint :: WalletId -> stm (Maybe (Wallet s))
putCheckpoint :: WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
walletsDB :: DBVar stm (DeltaMap WalletId (DeltaWalletState s))
listWallets :: stm [WalletId]
removeWallet :: WalletId -> ExceptT ErrNoSuchWallet stm ()
initializeWallet :: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
atomically :: ()
prune :: ()
rollbackTo :: ()
readGenesisParameters :: ()
readPrivateKey :: ()
putPrivateKey :: ()
removePendingOrExpiredTx :: ()
updatePendingTxForExpiry :: ()
readLocalTxSubmissionPending :: ()
putLocalTxSubmission :: ()
getTx :: ()
readTxHistory :: ()
putTxHistory :: ()
readDelegationRewardBalance :: ()
putDelegationRewardBalance :: ()
putDelegationCertificate :: ()
isStakeKeyRegistered :: ()
readWalletMeta :: ()
putWalletMeta :: ()
listCheckpoints :: ()
readCheckpoint :: ()
putCheckpoint :: ()
walletsDB :: ()
listWallets :: ()
removeWallet :: ()
initializeWallet :: ()
..} -> do
    Wallet s
cp <- (stm (Either ErrReadAccountPublicKey (Wallet s))
 -> IO (Either ErrReadAccountPublicKey (Wallet s)))
-> ExceptT ErrReadAccountPublicKey stm (Wallet s)
-> ExceptT ErrReadAccountPublicKey IO (Wallet s)
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT stm (Either ErrReadAccountPublicKey (Wallet s))
-> IO (Either ErrReadAccountPublicKey (Wallet s))
forall a. stm a -> IO a
atomically
        (ExceptT ErrReadAccountPublicKey stm (Wallet s)
 -> ExceptT ErrReadAccountPublicKey IO (Wallet s))
-> ExceptT ErrReadAccountPublicKey stm (Wallet s)
-> ExceptT ErrReadAccountPublicKey IO (Wallet s)
forall a b. (a -> b) -> a -> b
$ (ErrNoSuchWallet -> ErrReadAccountPublicKey)
-> ExceptT ErrNoSuchWallet stm (Wallet s)
-> ExceptT ErrReadAccountPublicKey stm (Wallet s)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ErrNoSuchWallet -> ErrReadAccountPublicKey
ErrReadAccountPublicKeyNoSuchWallet
        (ExceptT ErrNoSuchWallet stm (Wallet s)
 -> ExceptT ErrReadAccountPublicKey stm (Wallet s))
-> ExceptT ErrNoSuchWallet stm (Wallet s)
-> ExceptT ErrReadAccountPublicKey stm (Wallet s)
forall a b. (a -> b) -> a -> b
$ WalletId
-> stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s)
forall (m :: * -> *) a.
Monad m =>
WalletId -> m (Maybe a) -> ExceptT ErrNoSuchWallet m a
withNoSuchWallet WalletId
wid
        (stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s))
-> stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s)
forall a b. (a -> b) -> a -> b
$ WalletId -> stm (Maybe (Wallet s))
readCheckpoint WalletId
wid
    k 'AccountK XPub
-> ExceptT ErrReadAccountPublicKey IO (k 'AccountK XPub)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (k 'AccountK XPub
 -> ExceptT ErrReadAccountPublicKey IO (k 'AccountK XPub))
-> k 'AccountK XPub
-> ExceptT ErrReadAccountPublicKey IO (k 'AccountK XPub)
forall a b. (a -> b) -> a -> b
$ s -> k 'AccountK XPub
forall s (key :: Depth -> * -> *).
GetAccount s key =>
s -> key 'AccountK XPub
getAccount (Wallet s -> s
forall s. Wallet s -> s
getState Wallet s
cp)
  where
    db :: DBLayer IO s k
db = ctx
ctx ctx
-> ((DBLayer IO s k -> Const (DBLayer IO s k) (DBLayer IO s k))
    -> ctx -> Const (DBLayer IO s k) ctx)
-> DBLayer IO s k
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx. HasDBLayer IO s k ctx => Lens' ctx (DBLayer IO s k)
forall (m :: * -> *) s (k :: Depth -> * -> *) ctx.
HasDBLayer m s k ctx =>
Lens' ctx (DBLayer m s k)
dbLayer @IO @s @k

writePolicyPublicKey
    :: forall ctx s (n :: NetworkDiscriminant).
        ( HasDBLayer IO s ShelleyKey ctx
        , s ~ SeqState n ShelleyKey
        )
    => ctx
    -> WalletId
    -> Passphrase "user"
    -> ExceptT ErrWritePolicyPublicKey IO (ShelleyKey 'PolicyK XPub)
writePolicyPublicKey :: ctx
-> WalletId
-> Passphrase "user"
-> ExceptT ErrWritePolicyPublicKey IO (ShelleyKey 'PolicyK XPub)
writePolicyPublicKey ctx
ctx WalletId
wid Passphrase "user"
pwd = DBLayer IO s ShelleyKey
db DBLayer IO s ShelleyKey
-> (DBLayer IO s ShelleyKey
    -> ExceptT ErrWritePolicyPublicKey IO (ShelleyKey 'PolicyK XPub))
-> ExceptT ErrWritePolicyPublicKey IO (ShelleyKey 'PolicyK XPub)
forall a b. a -> (a -> b) -> b
& \DBLayer{stm [WalletId]
DBVar stm (DeltaMap WalletId (DeltaWalletState s))
WalletId -> stm [LocalTxSubmissionStatus SealedTx]
WalletId -> stm [ChainPoint]
WalletId -> stm (Maybe (ShelleyKey 'RootK XPrv, PassphraseHash))
WalletId -> stm (Maybe GenesisParameters)
WalletId -> stm (Maybe WalletMetadata)
WalletId -> stm (Maybe (Wallet s))
WalletId -> stm Coin
WalletId -> ExceptT ErrNoSuchWallet stm Bool
WalletId -> ExceptT ErrNoSuchWallet stm ()
WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
WalletId
-> (ShelleyKey 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
forall a. stm a -> IO a
atomically :: forall a. stm a -> IO a
prune :: WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
rollbackTo :: WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
readGenesisParameters :: WalletId -> stm (Maybe GenesisParameters)
readPrivateKey :: WalletId -> stm (Maybe (ShelleyKey 'RootK XPrv, PassphraseHash))
putPrivateKey :: WalletId
-> (ShelleyKey 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
removePendingOrExpiredTx :: WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
updatePendingTxForExpiry :: WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
readLocalTxSubmissionPending :: WalletId -> stm [LocalTxSubmissionStatus SealedTx]
putLocalTxSubmission :: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
getTx :: WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
readTxHistory :: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
putTxHistory :: WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
readDelegationRewardBalance :: WalletId -> stm Coin
putDelegationRewardBalance :: WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
putDelegationCertificate :: WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
isStakeKeyRegistered :: WalletId -> ExceptT ErrNoSuchWallet stm Bool
readWalletMeta :: WalletId -> stm (Maybe WalletMetadata)
putWalletMeta :: WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
listCheckpoints :: WalletId -> stm [ChainPoint]
readCheckpoint :: WalletId -> stm (Maybe (Wallet s))
putCheckpoint :: WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
walletsDB :: DBVar stm (DeltaMap WalletId (DeltaWalletState s))
listWallets :: stm [WalletId]
removeWallet :: WalletId -> ExceptT ErrNoSuchWallet stm ()
initializeWallet :: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
atomically :: ()
prune :: ()
rollbackTo :: ()
readGenesisParameters :: ()
readPrivateKey :: ()
putPrivateKey :: ()
removePendingOrExpiredTx :: ()
updatePendingTxForExpiry :: ()
readLocalTxSubmissionPending :: ()
putLocalTxSubmission :: ()
getTx :: ()
readTxHistory :: ()
putTxHistory :: ()
readDelegationRewardBalance :: ()
putDelegationRewardBalance :: ()
putDelegationCertificate :: ()
isStakeKeyRegistered :: ()
readWalletMeta :: ()
putWalletMeta :: ()
listCheckpoints :: ()
readCheckpoint :: ()
putCheckpoint :: ()
walletsDB :: ()
listWallets :: ()
removeWallet :: ()
initializeWallet :: ()
..} -> do
    Wallet s
cp <- (stm (Either ErrWritePolicyPublicKey (Wallet s))
 -> IO (Either ErrWritePolicyPublicKey (Wallet s)))
-> ExceptT ErrWritePolicyPublicKey stm (Wallet s)
-> ExceptT ErrWritePolicyPublicKey IO (Wallet s)
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT stm (Either ErrWritePolicyPublicKey (Wallet s))
-> IO (Either ErrWritePolicyPublicKey (Wallet s))
forall a. stm a -> IO a
atomically
        (ExceptT ErrWritePolicyPublicKey stm (Wallet s)
 -> ExceptT ErrWritePolicyPublicKey IO (Wallet s))
-> ExceptT ErrWritePolicyPublicKey stm (Wallet s)
-> ExceptT ErrWritePolicyPublicKey IO (Wallet s)
forall a b. (a -> b) -> a -> b
$ (ErrNoSuchWallet -> ErrWritePolicyPublicKey)
-> ExceptT ErrNoSuchWallet stm (Wallet s)
-> ExceptT ErrWritePolicyPublicKey stm (Wallet s)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ErrNoSuchWallet -> ErrWritePolicyPublicKey
ErrWritePolicyPublicKeyNoSuchWallet
        (ExceptT ErrNoSuchWallet stm (Wallet s)
 -> ExceptT ErrWritePolicyPublicKey stm (Wallet s))
-> ExceptT ErrNoSuchWallet stm (Wallet s)
-> ExceptT ErrWritePolicyPublicKey stm (Wallet s)
forall a b. (a -> b) -> a -> b
$ WalletId
-> stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s)
forall (m :: * -> *) a.
Monad m =>
WalletId -> m (Maybe a) -> ExceptT ErrNoSuchWallet m a
withNoSuchWallet WalletId
wid
        (stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s))
-> stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s)
forall a b. (a -> b) -> a -> b
$ WalletId -> stm (Maybe (Wallet s))
readCheckpoint WalletId
wid

    let (SeqPrologue seqState) = s -> Prologue s
forall s. AddressBookIso s => s -> Prologue s
getPrologue (s -> Prologue s) -> s -> Prologue s
forall a b. (a -> b) -> a -> b
$ Wallet s -> s
forall s. Wallet s -> s
getState Wallet s
cp

    ShelleyKey 'PolicyK XPub
policyXPub <- ctx
-> WalletId
-> Passphrase "user"
-> (ErrWithRootKey -> ErrWritePolicyPublicKey)
-> (ShelleyKey 'RootK XPrv
    -> PassphraseScheme
    -> ExceptT ErrWritePolicyPublicKey IO (ShelleyKey 'PolicyK XPub))
-> ExceptT ErrWritePolicyPublicKey IO (ShelleyKey 'PolicyK XPub)
forall ctx s (k :: Depth -> * -> *) e a.
HasDBLayer IO s k ctx =>
ctx
-> WalletId
-> Passphrase "user"
-> (ErrWithRootKey -> e)
-> (k 'RootK XPrv -> PassphraseScheme -> ExceptT e IO a)
-> ExceptT e IO a
withRootKey
        @ctx @s @ShelleyKey ctx
ctx WalletId
wid Passphrase "user"
pwd ErrWithRootKey -> ErrWritePolicyPublicKey
ErrWritePolicyPublicKeyWithRootKey ((ShelleyKey 'RootK XPrv
  -> PassphraseScheme
  -> ExceptT ErrWritePolicyPublicKey IO (ShelleyKey 'PolicyK XPub))
 -> ExceptT ErrWritePolicyPublicKey IO (ShelleyKey 'PolicyK XPub))
-> (ShelleyKey 'RootK XPrv
    -> PassphraseScheme
    -> ExceptT ErrWritePolicyPublicKey IO (ShelleyKey 'PolicyK XPub))
-> ExceptT ErrWritePolicyPublicKey IO (ShelleyKey 'PolicyK XPub)
forall a b. (a -> b) -> a -> b
$
        \ShelleyKey 'RootK XPrv
rootK PassphraseScheme
scheme -> do
            let encPwd :: Passphrase "encryption"
encPwd = PassphraseScheme -> Passphrase "user" -> Passphrase "encryption"
preparePassphrase PassphraseScheme
scheme Passphrase "user"
pwd
            let xprv :: XPrv
xprv = Passphrase "encryption" -> XPrv -> Index 'Hardened 'PolicyK -> XPrv
forall (purpose :: Symbol).
Passphrase purpose -> XPrv -> Index 'Hardened 'PolicyK -> XPrv
derivePolicyPrivateKey Passphrase "encryption"
encPwd (ShelleyKey 'RootK XPrv -> XPrv
forall (key :: Depth -> * -> *) (depth :: Depth) raw.
WalletKey key =>
key depth raw -> raw
getRawKey ShelleyKey 'RootK XPrv
rootK) Index 'Hardened 'PolicyK
forall a. Bounded a => a
minBound
            ShelleyKey 'PolicyK XPub
-> ExceptT ErrWritePolicyPublicKey IO (ShelleyKey 'PolicyK XPub)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShelleyKey 'PolicyK XPub
 -> ExceptT ErrWritePolicyPublicKey IO (ShelleyKey 'PolicyK XPub))
-> ShelleyKey 'PolicyK XPub
-> ExceptT ErrWritePolicyPublicKey IO (ShelleyKey 'PolicyK XPub)
forall a b. (a -> b) -> a -> b
$ XPub -> ShelleyKey 'PolicyK XPub
forall (key :: Depth -> * -> *) raw (depth :: Depth).
WalletKey key =>
raw -> key depth raw
liftRawKey (XPub -> ShelleyKey 'PolicyK XPub)
-> XPub -> ShelleyKey 'PolicyK XPub
forall a b. (a -> b) -> a -> b
$ HasCallStack => XPrv -> XPub
XPrv -> XPub
toXPub XPrv
xprv

    let seqState' :: SeqState n ShelleyKey
seqState' = SeqState n ShelleyKey
seqState SeqState n ShelleyKey
-> (SeqState n ShelleyKey -> SeqState n ShelleyKey)
-> SeqState n ShelleyKey
forall a b. a -> (a -> b) -> b
& IsLabel
  "policyXPub"
  ((Maybe (ShelleyKey 'PolicyK XPub)
    -> Identity (Maybe (ShelleyKey 'PolicyK XPub)))
   -> SeqState n ShelleyKey -> Identity (SeqState n ShelleyKey))
(Maybe (ShelleyKey 'PolicyK XPub)
 -> Identity (Maybe (ShelleyKey 'PolicyK XPub)))
-> SeqState n ShelleyKey -> Identity (SeqState n ShelleyKey)
#policyXPub ((Maybe (ShelleyKey 'PolicyK XPub)
  -> Identity (Maybe (ShelleyKey 'PolicyK XPub)))
 -> SeqState n ShelleyKey -> Identity (SeqState n ShelleyKey))
-> Maybe (ShelleyKey 'PolicyK XPub)
-> SeqState n ShelleyKey
-> SeqState n ShelleyKey
forall a b s t.
((a -> Identity b) -> s -> Identity t) -> b -> s -> t
.~ ShelleyKey 'PolicyK XPub -> Maybe (ShelleyKey 'PolicyK XPub)
forall a. a -> Maybe a
Just ShelleyKey 'PolicyK XPub
policyXPub
    IO (Either ErrWritePolicyPublicKey ())
-> ExceptT ErrWritePolicyPublicKey IO ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ErrWritePolicyPublicKey ())
 -> ExceptT ErrWritePolicyPublicKey IO ())
-> IO (Either ErrWritePolicyPublicKey ())
-> ExceptT ErrWritePolicyPublicKey IO ()
forall a b. (a -> b) -> a -> b
$ stm (Either ErrWritePolicyPublicKey ())
-> IO (Either ErrWritePolicyPublicKey ())
forall a. stm a -> IO a
atomically (stm (Either ErrWritePolicyPublicKey ())
 -> IO (Either ErrWritePolicyPublicKey ()))
-> stm (Either ErrWritePolicyPublicKey ())
-> IO (Either ErrWritePolicyPublicKey ())
forall a b. (a -> b) -> a -> b
$ DBVar stm (DeltaMap WalletId (DeltaWalletState s))
-> (Map WalletId (WalletState (SeqState n ShelleyKey))
    -> (Maybe (DeltaMap WalletId (DeltaWalletState s)),
        Either ErrWritePolicyPublicKey ()))
-> stm (Either ErrWritePolicyPublicKey ())
forall da (m :: * -> *) a b.
(Delta da, Monad m, a ~ Base da) =>
DBVar m da -> (a -> (Maybe da, b)) -> m b
modifyDBMaybe DBVar stm (DeltaMap WalletId (DeltaWalletState s))
walletsDB ((Map WalletId (WalletState (SeqState n ShelleyKey))
  -> (Maybe (DeltaMap WalletId (DeltaWalletState s)),
      Either ErrWritePolicyPublicKey ()))
 -> stm (Either ErrWritePolicyPublicKey ()))
-> (Map WalletId (WalletState (SeqState n ShelleyKey))
    -> (Maybe (DeltaMap WalletId (DeltaWalletState s)),
        Either ErrWritePolicyPublicKey ()))
-> stm (Either ErrWritePolicyPublicKey ())
forall a b. (a -> b) -> a -> b
$
        WalletId
-> (ErrNoSuchWallet -> ErrWritePolicyPublicKey)
-> (WalletState (SeqState n ShelleyKey)
    -> Either
         ErrWritePolicyPublicKey
         ([DeltaWalletState1 (SeqState n ShelleyKey)], ()))
-> Map WalletId (WalletState (SeqState n ShelleyKey))
-> (Maybe
      (DeltaMap WalletId [DeltaWalletState1 (SeqState n ShelleyKey)]),
    Either ErrWritePolicyPublicKey ())
forall e w dw b.
WalletId
-> (ErrNoSuchWallet -> e)
-> (w -> Either e (dw, b))
-> Map WalletId w
-> (Maybe (DeltaMap WalletId dw), Either e b)
adjustNoSuchWallet WalletId
wid ErrNoSuchWallet -> ErrWritePolicyPublicKey
ErrWritePolicyPublicKeyNoSuchWallet ((WalletState (SeqState n ShelleyKey)
  -> Either
       ErrWritePolicyPublicKey
       ([DeltaWalletState1 (SeqState n ShelleyKey)], ()))
 -> Map WalletId (WalletState (SeqState n ShelleyKey))
 -> (Maybe
       (DeltaMap WalletId [DeltaWalletState1 (SeqState n ShelleyKey)]),
     Either ErrWritePolicyPublicKey ()))
-> (WalletState (SeqState n ShelleyKey)
    -> Either
         ErrWritePolicyPublicKey
         ([DeltaWalletState1 (SeqState n ShelleyKey)], ()))
-> Map WalletId (WalletState (SeqState n ShelleyKey))
-> (Maybe
      (DeltaMap WalletId [DeltaWalletState1 (SeqState n ShelleyKey)]),
    Either ErrWritePolicyPublicKey ())
forall a b. (a -> b) -> a -> b
$
        \WalletState (SeqState n ShelleyKey)
_ -> ([DeltaWalletState1 (SeqState n ShelleyKey)], ())
-> Either
     ErrWritePolicyPublicKey
     ([DeltaWalletState1 (SeqState n ShelleyKey)], ())
forall a b. b -> Either a b
Right ( [Prologue (SeqState n ShelleyKey)
-> DeltaWalletState1 (SeqState n ShelleyKey)
forall s. Prologue s -> DeltaWalletState1 s
ReplacePrologue (Prologue (SeqState n ShelleyKey)
 -> DeltaWalletState1 (SeqState n ShelleyKey))
-> Prologue (SeqState n ShelleyKey)
-> DeltaWalletState1 (SeqState n ShelleyKey)
forall a b. (a -> b) -> a -> b
$ SeqState n ShelleyKey -> Prologue (SeqState n ShelleyKey)
forall (n :: NetworkDiscriminant) (key :: Depth -> * -> *).
SeqState n key -> Prologue (SeqState n key)
SeqPrologue SeqState n ShelleyKey
seqState'], () )

    ShelleyKey 'PolicyK XPub
-> ExceptT ErrWritePolicyPublicKey IO (ShelleyKey 'PolicyK XPub)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ShelleyKey 'PolicyK XPub
policyXPub
  where
    db :: DBLayer IO s ShelleyKey
db = ctx
ctx ctx
-> ((DBLayer IO s ShelleyKey
     -> Const (DBLayer IO s ShelleyKey) (DBLayer IO s ShelleyKey))
    -> ctx -> Const (DBLayer IO s ShelleyKey) ctx)
-> DBLayer IO s ShelleyKey
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx.
HasDBLayer IO s ShelleyKey ctx =>
Lens' ctx (DBLayer IO s ShelleyKey)
forall (m :: * -> *) s (k :: Depth -> * -> *) ctx.
HasDBLayer m s k ctx =>
Lens' ctx (DBLayer m s k)
dbLayer @IO @s @ShelleyKey

-- | Retrieve any public account key of a wallet.
getAccountPublicKeyAtIndex
    :: forall ctx s k.
        ( HasDBLayer IO s k ctx
        , WalletKey k
        , GetPurpose k
        )
    => ctx
    -> WalletId
    -> Passphrase "user"
    -> DerivationIndex
    -> Maybe DerivationIndex
    -> ExceptT ErrReadAccountPublicKey IO (k 'AccountK XPub)
getAccountPublicKeyAtIndex :: ctx
-> WalletId
-> Passphrase "user"
-> DerivationIndex
-> Maybe DerivationIndex
-> ExceptT ErrReadAccountPublicKey IO (k 'AccountK XPub)
getAccountPublicKeyAtIndex ctx
ctx WalletId
wid Passphrase "user"
pwd DerivationIndex
ix Maybe DerivationIndex
purposeM = DBLayer IO s k
db DBLayer IO s k
-> (DBLayer IO s k
    -> ExceptT ErrReadAccountPublicKey IO (k 'AccountK XPub))
-> ExceptT ErrReadAccountPublicKey IO (k 'AccountK XPub)
forall a b. a -> (a -> b) -> b
& \DBLayer{stm [WalletId]
DBVar stm (DeltaMap WalletId (DeltaWalletState s))
WalletId -> stm [LocalTxSubmissionStatus SealedTx]
WalletId -> stm [ChainPoint]
WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
WalletId -> stm (Maybe GenesisParameters)
WalletId -> stm (Maybe WalletMetadata)
WalletId -> stm (Maybe (Wallet s))
WalletId -> stm Coin
WalletId -> ExceptT ErrNoSuchWallet stm Bool
WalletId -> ExceptT ErrNoSuchWallet stm ()
WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
forall a. stm a -> IO a
atomically :: forall a. stm a -> IO a
prune :: WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
rollbackTo :: WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
readGenesisParameters :: WalletId -> stm (Maybe GenesisParameters)
readPrivateKey :: WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
putPrivateKey :: WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
removePendingOrExpiredTx :: WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
updatePendingTxForExpiry :: WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
readLocalTxSubmissionPending :: WalletId -> stm [LocalTxSubmissionStatus SealedTx]
putLocalTxSubmission :: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
getTx :: WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
readTxHistory :: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
putTxHistory :: WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
readDelegationRewardBalance :: WalletId -> stm Coin
putDelegationRewardBalance :: WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
putDelegationCertificate :: WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
isStakeKeyRegistered :: WalletId -> ExceptT ErrNoSuchWallet stm Bool
readWalletMeta :: WalletId -> stm (Maybe WalletMetadata)
putWalletMeta :: WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
listCheckpoints :: WalletId -> stm [ChainPoint]
readCheckpoint :: WalletId -> stm (Maybe (Wallet s))
putCheckpoint :: WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
walletsDB :: DBVar stm (DeltaMap WalletId (DeltaWalletState s))
listWallets :: stm [WalletId]
removeWallet :: WalletId -> ExceptT ErrNoSuchWallet stm ()
initializeWallet :: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
atomically :: ()
prune :: ()
rollbackTo :: ()
readGenesisParameters :: ()
readPrivateKey :: ()
putPrivateKey :: ()
removePendingOrExpiredTx :: ()
updatePendingTxForExpiry :: ()
readLocalTxSubmissionPending :: ()
putLocalTxSubmission :: ()
getTx :: ()
readTxHistory :: ()
putTxHistory :: ()
readDelegationRewardBalance :: ()
putDelegationRewardBalance :: ()
putDelegationCertificate :: ()
isStakeKeyRegistered :: ()
readWalletMeta :: ()
putWalletMeta :: ()
listCheckpoints :: ()
readCheckpoint :: ()
putCheckpoint :: ()
walletsDB :: ()
listWallets :: ()
removeWallet :: ()
initializeWallet :: ()
..} -> do
    Index 'Hardened 'AccountK
acctIx <- (ErrInvalidDerivationIndex 'Hardened 'AccountK
 -> ErrReadAccountPublicKey)
-> ExceptT
     (ErrInvalidDerivationIndex 'Hardened 'AccountK)
     IO
     (Index 'Hardened 'AccountK)
-> ExceptT ErrReadAccountPublicKey IO (Index 'Hardened 'AccountK)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ErrInvalidDerivationIndex 'Hardened 'AccountK
-> ErrReadAccountPublicKey
ErrReadAccountPublicKeyInvalidAccountIndex (ExceptT
   (ErrInvalidDerivationIndex 'Hardened 'AccountK)
   IO
   (Index 'Hardened 'AccountK)
 -> ExceptT ErrReadAccountPublicKey IO (Index 'Hardened 'AccountK))
-> ExceptT
     (ErrInvalidDerivationIndex 'Hardened 'AccountK)
     IO
     (Index 'Hardened 'AccountK)
-> ExceptT ErrReadAccountPublicKey IO (Index 'Hardened 'AccountK)
forall a b. (a -> b) -> a -> b
$ DerivationIndex
-> ExceptT
     (ErrInvalidDerivationIndex 'Hardened 'AccountK)
     IO
     (Index 'Hardened 'AccountK)
forall (m :: * -> *) (level :: Depth) (whatever :: Depth).
Monad m =>
DerivationIndex
-> ExceptT
     (ErrInvalidDerivationIndex 'Hardened level)
     m
     (Index 'Hardened whatever)
guardHardIndex DerivationIndex
ix

    Index 'Hardened 'PurposeK
purpose <- ExceptT ErrReadAccountPublicKey IO (Index 'Hardened 'PurposeK)
-> (DerivationIndex
    -> ExceptT ErrReadAccountPublicKey IO (Index 'Hardened 'PurposeK))
-> Maybe DerivationIndex
-> ExceptT ErrReadAccountPublicKey IO (Index 'Hardened 'PurposeK)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Index 'Hardened 'PurposeK
-> ExceptT ErrReadAccountPublicKey IO (Index 'Hardened 'PurposeK)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GetPurpose k => Index 'Hardened 'PurposeK
forall (key :: Depth -> * -> *).
GetPurpose key =>
Index 'Hardened 'PurposeK
getPurpose @k))
        ((ErrInvalidDerivationIndex 'Hardened 'PurposeK
 -> ErrReadAccountPublicKey)
-> ExceptT
     (ErrInvalidDerivationIndex 'Hardened 'PurposeK)
     IO
     (Index 'Hardened 'PurposeK)
-> ExceptT ErrReadAccountPublicKey IO (Index 'Hardened 'PurposeK)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ErrInvalidDerivationIndex 'Hardened 'PurposeK
-> ErrReadAccountPublicKey
ErrReadAccountPublicKeyInvalidPurposeIndex (ExceptT
   (ErrInvalidDerivationIndex 'Hardened 'PurposeK)
   IO
   (Index 'Hardened 'PurposeK)
 -> ExceptT ErrReadAccountPublicKey IO (Index 'Hardened 'PurposeK))
-> (DerivationIndex
    -> ExceptT
         (ErrInvalidDerivationIndex 'Hardened 'PurposeK)
         IO
         (Index 'Hardened 'PurposeK))
-> DerivationIndex
-> ExceptT ErrReadAccountPublicKey IO (Index 'Hardened 'PurposeK)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DerivationIndex
-> ExceptT
     (ErrInvalidDerivationIndex 'Hardened 'PurposeK)
     IO
     (Index 'Hardened 'PurposeK)
forall (m :: * -> *) (level :: Depth) (whatever :: Depth).
Monad m =>
DerivationIndex
-> ExceptT
     (ErrInvalidDerivationIndex 'Hardened level)
     m
     (Index 'Hardened whatever)
guardHardIndex)
        Maybe DerivationIndex
purposeM

    Wallet s
_cp <- (stm (Either ErrReadAccountPublicKey (Wallet s))
 -> IO (Either ErrReadAccountPublicKey (Wallet s)))
-> ExceptT ErrReadAccountPublicKey stm (Wallet s)
-> ExceptT ErrReadAccountPublicKey IO (Wallet s)
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT stm (Either ErrReadAccountPublicKey (Wallet s))
-> IO (Either ErrReadAccountPublicKey (Wallet s))
forall a. stm a -> IO a
atomically
        (ExceptT ErrReadAccountPublicKey stm (Wallet s)
 -> ExceptT ErrReadAccountPublicKey IO (Wallet s))
-> ExceptT ErrReadAccountPublicKey stm (Wallet s)
-> ExceptT ErrReadAccountPublicKey IO (Wallet s)
forall a b. (a -> b) -> a -> b
$ (ErrNoSuchWallet -> ErrReadAccountPublicKey)
-> ExceptT ErrNoSuchWallet stm (Wallet s)
-> ExceptT ErrReadAccountPublicKey stm (Wallet s)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ErrNoSuchWallet -> ErrReadAccountPublicKey
ErrReadAccountPublicKeyNoSuchWallet
        (ExceptT ErrNoSuchWallet stm (Wallet s)
 -> ExceptT ErrReadAccountPublicKey stm (Wallet s))
-> ExceptT ErrNoSuchWallet stm (Wallet s)
-> ExceptT ErrReadAccountPublicKey stm (Wallet s)
forall a b. (a -> b) -> a -> b
$ WalletId
-> stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s)
forall (m :: * -> *) a.
Monad m =>
WalletId -> m (Maybe a) -> ExceptT ErrNoSuchWallet m a
withNoSuchWallet WalletId
wid
        (stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s))
-> stm (Maybe (Wallet s)) -> ExceptT ErrNoSuchWallet stm (Wallet s)
forall a b. (a -> b) -> a -> b
$ WalletId -> stm (Maybe (Wallet s))
readCheckpoint WalletId
wid

    ctx
-> WalletId
-> Passphrase "user"
-> (ErrWithRootKey -> ErrReadAccountPublicKey)
-> (k 'RootK XPrv
    -> PassphraseScheme
    -> ExceptT ErrReadAccountPublicKey IO (k 'AccountK XPub))
-> ExceptT ErrReadAccountPublicKey IO (k 'AccountK XPub)
forall ctx s (k :: Depth -> * -> *) e a.
HasDBLayer IO s k ctx =>
ctx
-> WalletId
-> Passphrase "user"
-> (ErrWithRootKey -> e)
-> (k 'RootK XPrv -> PassphraseScheme -> ExceptT e IO a)
-> ExceptT e IO a
withRootKey @ctx @s @k ctx
ctx WalletId
wid Passphrase "user"
pwd ErrWithRootKey -> ErrReadAccountPublicKey
ErrReadAccountPublicKeyRootKey
        ((k 'RootK XPrv
  -> PassphraseScheme
  -> ExceptT ErrReadAccountPublicKey IO (k 'AccountK XPub))
 -> ExceptT ErrReadAccountPublicKey IO (k 'AccountK XPub))
-> (k 'RootK XPrv
    -> PassphraseScheme
    -> ExceptT ErrReadAccountPublicKey IO (k 'AccountK XPub))
-> ExceptT ErrReadAccountPublicKey IO (k 'AccountK XPub)
forall a b. (a -> b) -> a -> b
$ \k 'RootK XPrv
rootK PassphraseScheme
scheme -> do
            let encPwd :: Passphrase "encryption"
encPwd = PassphraseScheme -> Passphrase "user" -> Passphrase "encryption"
preparePassphrase PassphraseScheme
scheme Passphrase "user"
pwd
            let xprv :: XPrv
xprv = Index 'Hardened 'PurposeK
-> Passphrase "encryption"
-> XPrv
-> Index 'Hardened 'AccountK
-> XPrv
deriveAccountPrivateKeyShelley Index 'Hardened 'PurposeK
purpose Passphrase "encryption"
encPwd (k 'RootK XPrv -> XPrv
forall (key :: Depth -> * -> *) (depth :: Depth) raw.
WalletKey key =>
key depth raw -> raw
getRawKey k 'RootK XPrv
rootK) Index 'Hardened 'AccountK
acctIx
            k 'AccountK XPub
-> ExceptT ErrReadAccountPublicKey IO (k 'AccountK XPub)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (k 'AccountK XPub
 -> ExceptT ErrReadAccountPublicKey IO (k 'AccountK XPub))
-> k 'AccountK XPub
-> ExceptT ErrReadAccountPublicKey IO (k 'AccountK XPub)
forall a b. (a -> b) -> a -> b
$ XPub -> k 'AccountK XPub
forall (key :: Depth -> * -> *) raw (depth :: Depth).
WalletKey key =>
raw -> key depth raw
liftRawKey (XPub -> k 'AccountK XPub) -> XPub -> k 'AccountK XPub
forall a b. (a -> b) -> a -> b
$ HasCallStack => XPrv -> XPub
XPrv -> XPub
toXPub XPrv
xprv
  where
    db :: DBLayer IO s k
db = ctx
ctx ctx
-> ((DBLayer IO s k -> Const (DBLayer IO s k) (DBLayer IO s k))
    -> ctx -> Const (DBLayer IO s k) ctx)
-> DBLayer IO s k
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx. HasDBLayer IO s k ctx => Lens' ctx (DBLayer IO s k)
forall (m :: * -> *) s (k :: Depth -> * -> *) ctx.
HasDBLayer m s k ctx =>
Lens' ctx (DBLayer m s k)
dbLayer @IO @s @k

guardSoftIndex
    :: Monad m
    => DerivationIndex
    -> ExceptT (ErrInvalidDerivationIndex 'Soft 'AddressK) m (Index 'Soft whatever)
guardSoftIndex :: DerivationIndex
-> ExceptT
     (ErrInvalidDerivationIndex 'Soft 'AddressK)
     m
     (Index 'Soft whatever)
guardSoftIndex DerivationIndex
ix =
    if DerivationIndex
ix DerivationIndex -> DerivationIndex -> Bool
forall a. Ord a => a -> a -> Bool
> Word32 -> DerivationIndex
DerivationIndex (Index 'Soft Any -> Word32
forall (derivationType :: DerivationType) (level :: Depth).
Index derivationType level -> Word32
getIndex @'Soft Index 'Soft Any
forall a. Bounded a => a
maxBound) Bool -> Bool -> Bool
|| DerivationIndex
ix DerivationIndex -> DerivationIndex -> Bool
forall a. Ord a => a -> a -> Bool
< Word32 -> DerivationIndex
DerivationIndex (Index 'Soft Any -> Word32
forall (derivationType :: DerivationType) (level :: Depth).
Index derivationType level -> Word32
getIndex @'Soft Index 'Soft Any
forall a. Bounded a => a
minBound)
    then ErrInvalidDerivationIndex 'Soft 'AddressK
-> ExceptT
     (ErrInvalidDerivationIndex 'Soft 'AddressK)
     m
     (Index 'Soft whatever)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (ErrInvalidDerivationIndex 'Soft 'AddressK
 -> ExceptT
      (ErrInvalidDerivationIndex 'Soft 'AddressK)
      m
      (Index 'Soft whatever))
-> ErrInvalidDerivationIndex 'Soft 'AddressK
-> ExceptT
     (ErrInvalidDerivationIndex 'Soft 'AddressK)
     m
     (Index 'Soft whatever)
forall a b. (a -> b) -> a -> b
$ Index 'Soft 'AddressK
-> Index 'Soft 'AddressK
-> DerivationIndex
-> ErrInvalidDerivationIndex 'Soft 'AddressK
forall (derivation :: DerivationType) (level :: Depth).
Index derivation level
-> Index derivation level
-> DerivationIndex
-> ErrInvalidDerivationIndex derivation level
ErrIndexOutOfBound Index 'Soft 'AddressK
forall a. Bounded a => a
minBound Index 'Soft 'AddressK
forall a. Bounded a => a
maxBound DerivationIndex
ix
    else Index 'Soft whatever
-> ExceptT
     (ErrInvalidDerivationIndex 'Soft 'AddressK)
     m
     (Index 'Soft whatever)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word32 -> Index 'Soft whatever
forall (derivationType :: DerivationType) (level :: Depth).
Word32 -> Index derivationType level
Index (Word32 -> Index 'Soft whatever) -> Word32 -> Index 'Soft whatever
forall a b. (a -> b) -> a -> b
$ DerivationIndex -> Word32
getDerivationIndex DerivationIndex
ix)

guardHardIndex
    :: Monad m
    => DerivationIndex
    -> ExceptT (ErrInvalidDerivationIndex 'Hardened level) m (Index 'Hardened whatever)
guardHardIndex :: DerivationIndex
-> ExceptT
     (ErrInvalidDerivationIndex 'Hardened level)
     m
     (Index 'Hardened whatever)
guardHardIndex DerivationIndex
ix =
    if DerivationIndex
ix DerivationIndex -> DerivationIndex -> Bool
forall a. Ord a => a -> a -> Bool
> Word32 -> DerivationIndex
DerivationIndex (Index 'Hardened Any -> Word32
forall (derivationType :: DerivationType) (level :: Depth).
Index derivationType level -> Word32
getIndex @'Hardened Index 'Hardened Any
forall a. Bounded a => a
maxBound) Bool -> Bool -> Bool
|| DerivationIndex
ix DerivationIndex -> DerivationIndex -> Bool
forall a. Ord a => a -> a -> Bool
< Word32 -> DerivationIndex
DerivationIndex (Index 'Hardened Any -> Word32
forall (derivationType :: DerivationType) (level :: Depth).
Index derivationType level -> Word32
getIndex @'Hardened Index 'Hardened Any
forall a. Bounded a => a
minBound)
    then ErrInvalidDerivationIndex 'Hardened level
-> ExceptT
     (ErrInvalidDerivationIndex 'Hardened level)
     m
     (Index 'Hardened whatever)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (ErrInvalidDerivationIndex 'Hardened level
 -> ExceptT
      (ErrInvalidDerivationIndex 'Hardened level)
      m
      (Index 'Hardened whatever))
-> ErrInvalidDerivationIndex 'Hardened level
-> ExceptT
     (ErrInvalidDerivationIndex 'Hardened level)
     m
     (Index 'Hardened whatever)
forall a b. (a -> b) -> a -> b
$ Index 'Hardened level
-> Index 'Hardened level
-> DerivationIndex
-> ErrInvalidDerivationIndex 'Hardened level
forall (derivation :: DerivationType) (level :: Depth).
Index derivation level
-> Index derivation level
-> DerivationIndex
-> ErrInvalidDerivationIndex derivation level
ErrIndexOutOfBound Index 'Hardened level
forall a. Bounded a => a
minBound Index 'Hardened level
forall a. Bounded a => a
maxBound DerivationIndex
ix
    else Index 'Hardened whatever
-> ExceptT
     (ErrInvalidDerivationIndex 'Hardened level)
     m
     (Index 'Hardened whatever)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word32 -> Index 'Hardened whatever
forall (derivationType :: DerivationType) (level :: Depth).
Word32 -> Index derivationType level
Index (Word32 -> Index 'Hardened whatever)
-> Word32 -> Index 'Hardened whatever
forall a b. (a -> b) -> a -> b
$ DerivationIndex -> Word32
getDerivationIndex DerivationIndex
ix)

updateCosigner
    :: forall ctx s k n.
        ( s ~ SharedState n k
--        , MkKeyFingerprint k (Proxy n, k 'AddressK CC.XPub)
        , MkKeyFingerprint k Address
        , SoftDerivation k
        , Typeable n
        , WalletKey k
        , HasDBLayer IO s k ctx
        , k ~ SharedKey
        )
    => ctx
    -> WalletId
    -> k 'AccountK XPub
    -> Cosigner
    -> CredentialType
    -> ExceptT ErrAddCosignerKey IO ()
updateCosigner :: ctx
-> WalletId
-> k 'AccountK XPub
-> Cosigner
-> CredentialType
-> ExceptT ErrAddCosignerKey IO ()
updateCosigner ctx
ctx WalletId
wid k 'AccountK XPub
cosignerXPub Cosigner
cosigner CredentialType
cred = DBLayer IO s k
db DBLayer IO s k
-> (DBLayer IO s k -> ExceptT ErrAddCosignerKey IO ())
-> ExceptT ErrAddCosignerKey IO ()
forall a b. a -> (a -> b) -> b
& \DBLayer{stm [WalletId]
DBVar stm (DeltaMap WalletId (DeltaWalletState s))
WalletId -> stm [LocalTxSubmissionStatus SealedTx]
WalletId -> stm [ChainPoint]
WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
WalletId -> stm (Maybe GenesisParameters)
WalletId -> stm (Maybe WalletMetadata)
WalletId -> stm (Maybe (Wallet s))
WalletId -> stm Coin
WalletId -> ExceptT ErrNoSuchWallet stm Bool
WalletId -> ExceptT ErrNoSuchWallet stm ()
WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
forall a. stm a -> IO a
atomically :: forall a. stm a -> IO a
prune :: WalletId
-> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ()
rollbackTo :: WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint
readGenesisParameters :: WalletId -> stm (Maybe GenesisParameters)
readPrivateKey :: WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash))
putPrivateKey :: WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
removePendingOrExpiredTx :: WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ()
updatePendingTxForExpiry :: WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ()
readLocalTxSubmissionPending :: WalletId -> stm [LocalTxSubmissionStatus SealedTx]
putLocalTxSubmission :: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
getTx :: WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
readTxHistory :: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
putTxHistory :: WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ()
readDelegationRewardBalance :: WalletId -> stm Coin
putDelegationRewardBalance :: WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ()
putDelegationCertificate :: WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
isStakeKeyRegistered :: WalletId -> ExceptT ErrNoSuchWallet stm Bool
readWalletMeta :: WalletId -> stm (Maybe WalletMetadata)
putWalletMeta :: WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ()
listCheckpoints :: WalletId -> stm [ChainPoint]
readCheckpoint :: WalletId -> stm (Maybe (Wallet s))
putCheckpoint :: WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ()
walletsDB :: DBVar stm (DeltaMap WalletId (DeltaWalletState s))
listWallets :: stm [WalletId]
removeWallet :: WalletId -> ExceptT ErrNoSuchWallet stm ()
initializeWallet :: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
atomically :: ()
prune :: ()
rollbackTo :: ()
readGenesisParameters :: ()
readPrivateKey :: ()
putPrivateKey :: ()
removePendingOrExpiredTx :: ()
updatePendingTxForExpiry :: ()
readLocalTxSubmissionPending :: ()
putLocalTxSubmission :: ()
getTx :: ()
readTxHistory :: ()
putTxHistory :: ()
readDelegationRewardBalance :: ()
putDelegationRewardBalance :: ()
putDelegationCertificate :: ()
isStakeKeyRegistered :: ()
readWalletMeta :: ()
putWalletMeta :: ()
listCheckpoints :: ()
readCheckpoint :: ()
putCheckpoint :: ()
walletsDB :: ()
listWallets :: ()
removeWallet :: ()
initializeWallet :: ()
..} ->
    IO (Either ErrAddCosignerKey ()) -> ExceptT ErrAddCosignerKey IO ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ErrAddCosignerKey ())
 -> ExceptT ErrAddCosignerKey IO ())
-> IO (Either ErrAddCosignerKey ())
-> ExceptT ErrAddCosignerKey IO ()
forall a b. (a -> b) -> a -> b
$ stm (Either ErrAddCosignerKey ())
-> IO (Either ErrAddCosignerKey ())
forall a. stm a -> IO a
atomically (stm (Either ErrAddCosignerKey ())
 -> IO (Either ErrAddCosignerKey ()))
-> stm (Either ErrAddCosignerKey ())
-> IO (Either ErrAddCosignerKey ())
forall a b. (a -> b) -> a -> b
$ DBVar stm (DeltaMap WalletId (DeltaWalletState s))
-> (Map WalletId (WalletState (SharedState n k))
    -> (Maybe (DeltaMap WalletId (DeltaWalletState s)),
        Either ErrAddCosignerKey ()))
-> stm (Either ErrAddCosignerKey ())
forall da (m :: * -> *) a b.
(Delta da, Monad m, a ~ Base da) =>
DBVar m da -> (a -> (Maybe da, b)) -> m b
modifyDBMaybe DBVar stm (DeltaMap WalletId (DeltaWalletState s))
walletsDB ((Map WalletId (WalletState (SharedState n k))
  -> (Maybe (DeltaMap WalletId (DeltaWalletState s)),
      Either ErrAddCosignerKey ()))
 -> stm (Either ErrAddCosignerKey ()))
-> (Map WalletId (WalletState (SharedState n k))
    -> (Maybe (DeltaMap WalletId (DeltaWalletState s)),
        Either ErrAddCosignerKey ()))
-> stm (Either ErrAddCosignerKey ())
forall a b. (a -> b) -> a -> b
$
        WalletId
-> (ErrNoSuchWallet -> ErrAddCosignerKey)
-> (WalletState (SharedState n k)
    -> Either
         ErrAddCosignerKey ([DeltaWalletState1 (SharedState n k)], ()))
-> Map WalletId (WalletState (SharedState n k))
-> (Maybe
      (DeltaMap WalletId [DeltaWalletState1 (SharedState n k)]),
    Either ErrAddCosignerKey ())
forall e w dw b.
WalletId
-> (ErrNoSuchWallet -> e)
-> (w -> Either e (dw, b))
-> Map WalletId w
-> (Maybe (DeltaMap WalletId dw), Either e b)
adjustNoSuchWallet WalletId
wid ErrNoSuchWallet -> ErrAddCosignerKey
ErrAddCosignerKeyNoSuchWallet
            WalletState (SharedState n k)
-> Either
     ErrAddCosignerKey ([DeltaWalletState1 (SharedState n k)], ())
updateCosigner'
  where
    db :: DBLayer IO s k
db = ctx
ctx ctx
-> ((DBLayer IO s k -> Const (DBLayer IO s k) (DBLayer IO s k))
    -> ctx -> Const (DBLayer IO s k) ctx)
-> DBLayer IO s k
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx. HasDBLayer IO s k ctx => Lens' ctx (DBLayer IO s k)
forall (m :: * -> *) s (k :: Depth -> * -> *) ctx.
HasDBLayer m s k ctx =>
Lens' ctx (DBLayer m s k)
dbLayer @_ @s @k
    updateCosigner' :: WalletState (SharedState n k)
-> Either
     ErrAddCosignerKey ([DeltaWalletState1 (SharedState n k)], ())
updateCosigner' WalletState (SharedState n k)
wallet =
        case (Cosigner, k 'AccountK XPub)
-> CredentialType
-> SharedState n k
-> Either ErrAddCosigner (SharedState n k)
forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
(SupportsDiscovery n k, WalletKey k, k ~ SharedKey) =>
(Cosigner, k 'AccountK XPub)
-> CredentialType
-> SharedState n k
-> Either ErrAddCosigner (SharedState n k)
addCosignerAccXPub (Cosigner
cosigner, k 'AccountK XPub
cosignerXPub) CredentialType
cred SharedState n k
s0 of
            Left ErrAddCosigner
err -> ErrAddCosignerKey
-> Either
     ErrAddCosignerKey ([DeltaWalletState1 (SharedState n k)], ())
forall a b. a -> Either a b
Left (ErrAddCosignerKey
 -> Either
      ErrAddCosignerKey ([DeltaWalletState1 (SharedState n k)], ()))
-> ErrAddCosignerKey
-> Either
     ErrAddCosignerKey ([DeltaWalletState1 (SharedState n k)], ())
forall a b. (a -> b) -> a -> b
$ ErrAddCosigner -> ErrAddCosignerKey
ErrAddCosignerKey ErrAddCosigner
err
            Right SharedState n k
s1 -> ([DeltaWalletState1 (SharedState n k)], ())
-> Either
     ErrAddCosignerKey ([DeltaWalletState1 (SharedState n k)], ())
forall a b. b -> Either a b
Right ([Prologue (SharedState n k) -> DeltaWalletState1 (SharedState n k)
forall s. Prologue s -> DeltaWalletState1 s
ReplacePrologue (Prologue (SharedState n k) -> DeltaWalletState1 (SharedState n k))
-> Prologue (SharedState n k)
-> DeltaWalletState1 (SharedState n k)
forall a b. (a -> b) -> a -> b
$ SharedState n k -> Prologue (SharedState n k)
forall s. AddressBookIso s => s -> Prologue s
getPrologue SharedState n k
s1], ())
      where
        s0 :: SharedState n k
s0 = Wallet (SharedState n k) -> SharedState n k
forall s. Wallet s -> s
getState (Wallet (SharedState n k) -> SharedState n k)
-> Wallet (SharedState n k) -> SharedState n k
forall a b. (a -> b) -> a -> b
$ WalletState (SharedState n k) -> Wallet (SharedState n k)
forall s. AddressBookIso s => WalletState s -> Wallet s
getLatest WalletState (SharedState n k)
wallet

-- NOTE
-- Addresses coming from the transaction history might be base (having payment credential) or
-- base addresses (containing both payment and delegation credentials).
-- So we normalize them all to be base addresses to make sure that we compare them correctly.
normalizeSharedAddress
    :: forall n k. ( Shared.SupportsDiscovery n k, k ~ SharedKey )
    => SharedState n k
    -> Address
    -> Maybe Address
normalizeSharedAddress :: SharedState n k -> Address -> Maybe Address
normalizeSharedAddress SharedState n k
st Address
addr = case SharedState n k -> Readiness (SharedAddressPools k)
forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
SharedState n k -> Readiness (SharedAddressPools k)
Shared.ready SharedState n k
st of
    Readiness (SharedAddressPools k)
Shared.Pending -> Maybe Address
forall a. Maybe a
Nothing
    Shared.Active SharedAddressPools k
_ -> do
        let dTM :: Maybe ScriptTemplate
dTM = SharedState n k -> Maybe ScriptTemplate
forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
SharedState n k -> Maybe ScriptTemplate
Shared.delegationTemplate SharedState n k
st
        KeyFingerprint "payment" k
fingerprint <- Either (ErrMkKeyFingerprint k Address) (KeyFingerprint "payment" k)
-> Maybe (KeyFingerprint "payment" k)
forall a b. Either a b -> Maybe b
eitherToMaybe (Address
-> Either
     (ErrMkKeyFingerprint k Address) (KeyFingerprint "payment" k)
forall (key :: Depth -> * -> *) from.
MkKeyFingerprint key from =>
from
-> Either
     (ErrMkKeyFingerprint key from) (KeyFingerprint "payment" key)
paymentKeyFingerprint @k Address
addr)
        let (Maybe (Index 'Soft 'ScriptK)
ixM, SharedState n k
_) = Address
-> SharedState n k
-> (Maybe (Index 'Soft 'ScriptK), SharedState n k)
forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
SupportsDiscovery n k =>
Address
-> SharedState n k
-> (Maybe (Index 'Soft 'ScriptK), SharedState n k)
Shared.isShared Address
addr SharedState n k
st
        case (Maybe ScriptTemplate
dTM, Maybe (Index 'Soft 'ScriptK)
ixM) of
            (Just ScriptTemplate
dT, Just Index 'Soft 'ScriptK
ix) ->
                Address -> Maybe Address
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Address -> Maybe Address) -> Address -> Maybe Address
forall a b. (a -> b) -> a -> b
$ Index 'Soft 'ScriptK
-> ScriptTemplate -> KeyFingerprint "payment" k -> Address
forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
Typeable n =>
Index 'Soft 'ScriptK
-> ScriptTemplate -> KeyFingerprint "payment" k -> Address
Shared.liftDelegationAddress @n Index 'Soft 'ScriptK
ix ScriptTemplate
dT KeyFingerprint "payment" k
fingerprint
            (Maybe ScriptTemplate, Maybe (Index 'Soft 'ScriptK))
_ ->
                Address -> Maybe Address
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Address -> Maybe Address) -> Address -> Maybe Address
forall a b. (a -> b) -> a -> b
$ KeyFingerprint "payment" k -> Address
forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
Typeable n =>
KeyFingerprint "payment" k -> Address
Shared.liftPaymentAddress @n KeyFingerprint "payment" k
fingerprint

{-------------------------------------------------------------------------------
                                   Errors
-------------------------------------------------------------------------------}

data ErrSignMetadataWith
    = ErrSignMetadataWithRootKey ErrWithRootKey
        -- ^ The wallet exists, but there's no root key attached to it
    | ErrSignMetadataWithNoSuchWallet ErrNoSuchWallet
        -- ^ The wallet doesn't exist?
    | ErrSignMetadataWithInvalidIndex (ErrInvalidDerivationIndex 'Soft 'AddressK)
        -- ^ User provided a derivation index outside of the 'Soft' domain
    deriving (ErrSignMetadataWith -> ErrSignMetadataWith -> Bool
(ErrSignMetadataWith -> ErrSignMetadataWith -> Bool)
-> (ErrSignMetadataWith -> ErrSignMetadataWith -> Bool)
-> Eq ErrSignMetadataWith
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrSignMetadataWith -> ErrSignMetadataWith -> Bool
$c/= :: ErrSignMetadataWith -> ErrSignMetadataWith -> Bool
== :: ErrSignMetadataWith -> ErrSignMetadataWith -> Bool
$c== :: ErrSignMetadataWith -> ErrSignMetadataWith -> Bool
Eq, Int -> ErrSignMetadataWith -> ShowS
[ErrSignMetadataWith] -> ShowS
ErrSignMetadataWith -> String
(Int -> ErrSignMetadataWith -> ShowS)
-> (ErrSignMetadataWith -> String)
-> ([ErrSignMetadataWith] -> ShowS)
-> Show ErrSignMetadataWith
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrSignMetadataWith] -> ShowS
$cshowList :: [ErrSignMetadataWith] -> ShowS
show :: ErrSignMetadataWith -> String
$cshow :: ErrSignMetadataWith -> String
showsPrec :: Int -> ErrSignMetadataWith -> ShowS
$cshowsPrec :: Int -> ErrSignMetadataWith -> ShowS
Show)

data ErrDerivePublicKey
    = ErrDerivePublicKeyNoSuchWallet ErrNoSuchWallet
        -- ^ The wallet doesn't exist?
    | ErrDerivePublicKeyInvalidIndex (ErrInvalidDerivationIndex 'Soft 'AddressK)
        -- ^ User provided a derivation index outside of the 'Soft' domain
    deriving (ErrDerivePublicKey -> ErrDerivePublicKey -> Bool
(ErrDerivePublicKey -> ErrDerivePublicKey -> Bool)
-> (ErrDerivePublicKey -> ErrDerivePublicKey -> Bool)
-> Eq ErrDerivePublicKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrDerivePublicKey -> ErrDerivePublicKey -> Bool
$c/= :: ErrDerivePublicKey -> ErrDerivePublicKey -> Bool
== :: ErrDerivePublicKey -> ErrDerivePublicKey -> Bool
$c== :: ErrDerivePublicKey -> ErrDerivePublicKey -> Bool
Eq, Int -> ErrDerivePublicKey -> ShowS
[ErrDerivePublicKey] -> ShowS
ErrDerivePublicKey -> String
(Int -> ErrDerivePublicKey -> ShowS)
-> (ErrDerivePublicKey -> String)
-> ([ErrDerivePublicKey] -> ShowS)
-> Show ErrDerivePublicKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrDerivePublicKey] -> ShowS
$cshowList :: [ErrDerivePublicKey] -> ShowS
show :: ErrDerivePublicKey -> String
$cshow :: ErrDerivePublicKey -> String
showsPrec :: Int -> ErrDerivePublicKey -> ShowS
$cshowsPrec :: Int -> ErrDerivePublicKey -> ShowS
Show)

data ErrAddCosignerKey
    = ErrAddCosignerKeyNoSuchWallet ErrNoSuchWallet
        -- ^ The shared wallet doesn't exist?
    | ErrAddCosignerKey ErrAddCosigner
        -- ^ Error adding this co-signer to the shared wallet.
    deriving (ErrAddCosignerKey -> ErrAddCosignerKey -> Bool
(ErrAddCosignerKey -> ErrAddCosignerKey -> Bool)
-> (ErrAddCosignerKey -> ErrAddCosignerKey -> Bool)
-> Eq ErrAddCosignerKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrAddCosignerKey -> ErrAddCosignerKey -> Bool
$c/= :: ErrAddCosignerKey -> ErrAddCosignerKey -> Bool
== :: ErrAddCosignerKey -> ErrAddCosignerKey -> Bool
$c== :: ErrAddCosignerKey -> ErrAddCosignerKey -> Bool
Eq, Int -> ErrAddCosignerKey -> ShowS
[ErrAddCosignerKey] -> ShowS
ErrAddCosignerKey -> String
(Int -> ErrAddCosignerKey -> ShowS)
-> (ErrAddCosignerKey -> String)
-> ([ErrAddCosignerKey] -> ShowS)
-> Show ErrAddCosignerKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrAddCosignerKey] -> ShowS
$cshowList :: [ErrAddCosignerKey] -> ShowS
show :: ErrAddCosignerKey -> String
$cshow :: ErrAddCosignerKey -> String
showsPrec :: Int -> ErrAddCosignerKey -> ShowS
$cshowsPrec :: Int -> ErrAddCosignerKey -> ShowS
Show)

data ErrConstructSharedWallet
    = ErrConstructSharedWalletWrongScriptTemplate ErrScriptTemplate
        -- ^ The shared wallet' script template doesn't pass validation
    | ErrConstructSharedWalletInvalidIndex (ErrInvalidDerivationIndex 'Hardened 'AccountK)
        -- ^ User provided a derivation index outside of the 'Hard' domain
    deriving (ErrConstructSharedWallet -> ErrConstructSharedWallet -> Bool
(ErrConstructSharedWallet -> ErrConstructSharedWallet -> Bool)
-> (ErrConstructSharedWallet -> ErrConstructSharedWallet -> Bool)
-> Eq ErrConstructSharedWallet
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrConstructSharedWallet -> ErrConstructSharedWallet -> Bool
$c/= :: ErrConstructSharedWallet -> ErrConstructSharedWallet -> Bool
== :: ErrConstructSharedWallet -> ErrConstructSharedWallet -> Bool
$c== :: ErrConstructSharedWallet -> ErrConstructSharedWallet -> Bool
Eq, Int -> ErrConstructSharedWallet -> ShowS
[ErrConstructSharedWallet] -> ShowS
ErrConstructSharedWallet -> String
(Int -> ErrConstructSharedWallet -> ShowS)
-> (ErrConstructSharedWallet -> String)
-> ([ErrConstructSharedWallet] -> ShowS)
-> Show ErrConstructSharedWallet
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrConstructSharedWallet] -> ShowS
$cshowList :: [ErrConstructSharedWallet] -> ShowS
show :: ErrConstructSharedWallet -> String
$cshow :: ErrConstructSharedWallet -> String
showsPrec :: Int -> ErrConstructSharedWallet -> ShowS
$cshowsPrec :: Int -> ErrConstructSharedWallet -> ShowS
Show)

data ErrReadAccountPublicKey
    = ErrReadAccountPublicKeyNoSuchWallet ErrNoSuchWallet
        -- ^ The wallet doesn't exist?
    | ErrReadAccountPublicKeyInvalidAccountIndex (ErrInvalidDerivationIndex 'Hardened 'AccountK)
        -- ^ User provided a derivation index for account outside of the 'Hard' domain
    | ErrReadAccountPublicKeyInvalidPurposeIndex (ErrInvalidDerivationIndex 'Hardened 'PurposeK)
        -- ^ User provided a derivation index for purpose outside of the 'Hard' domain
    | ErrReadAccountPublicKeyRootKey ErrWithRootKey
        -- ^ The wallet exists, but there's no root key attached to it
    deriving (ErrReadAccountPublicKey -> ErrReadAccountPublicKey -> Bool
(ErrReadAccountPublicKey -> ErrReadAccountPublicKey -> Bool)
-> (ErrReadAccountPublicKey -> ErrReadAccountPublicKey -> Bool)
-> Eq ErrReadAccountPublicKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrReadAccountPublicKey -> ErrReadAccountPublicKey -> Bool
$c/= :: ErrReadAccountPublicKey -> ErrReadAccountPublicKey -> Bool
== :: ErrReadAccountPublicKey -> ErrReadAccountPublicKey -> Bool
$c== :: ErrReadAccountPublicKey -> ErrReadAccountPublicKey -> Bool
Eq, Int -> ErrReadAccountPublicKey -> ShowS
[ErrReadAccountPublicKey] -> ShowS
ErrReadAccountPublicKey -> String
(Int -> ErrReadAccountPublicKey -> ShowS)
-> (ErrReadAccountPublicKey -> String)
-> ([ErrReadAccountPublicKey] -> ShowS)
-> Show ErrReadAccountPublicKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrReadAccountPublicKey] -> ShowS
$cshowList :: [ErrReadAccountPublicKey] -> ShowS
show :: ErrReadAccountPublicKey -> String
$cshow :: ErrReadAccountPublicKey -> String
showsPrec :: Int -> ErrReadAccountPublicKey -> ShowS
$cshowsPrec :: Int -> ErrReadAccountPublicKey -> ShowS
Show)

data ErrInvalidDerivationIndex derivation level
    = ErrIndexOutOfBound (Index derivation level) (Index derivation level) DerivationIndex
    deriving (ErrInvalidDerivationIndex derivation level
-> ErrInvalidDerivationIndex derivation level -> Bool
(ErrInvalidDerivationIndex derivation level
 -> ErrInvalidDerivationIndex derivation level -> Bool)
-> (ErrInvalidDerivationIndex derivation level
    -> ErrInvalidDerivationIndex derivation level -> Bool)
-> Eq (ErrInvalidDerivationIndex derivation level)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (derivation :: DerivationType) (level :: Depth).
ErrInvalidDerivationIndex derivation level
-> ErrInvalidDerivationIndex derivation level -> Bool
/= :: ErrInvalidDerivationIndex derivation level
-> ErrInvalidDerivationIndex derivation level -> Bool
$c/= :: forall (derivation :: DerivationType) (level :: Depth).
ErrInvalidDerivationIndex derivation level
-> ErrInvalidDerivationIndex derivation level -> Bool
== :: ErrInvalidDerivationIndex derivation level
-> ErrInvalidDerivationIndex derivation level -> Bool
$c== :: forall (derivation :: DerivationType) (level :: Depth).
ErrInvalidDerivationIndex derivation level
-> ErrInvalidDerivationIndex derivation level -> Bool
Eq, Int -> ErrInvalidDerivationIndex derivation level -> ShowS
[ErrInvalidDerivationIndex derivation level] -> ShowS
ErrInvalidDerivationIndex derivation level -> String
(Int -> ErrInvalidDerivationIndex derivation level -> ShowS)
-> (ErrInvalidDerivationIndex derivation level -> String)
-> ([ErrInvalidDerivationIndex derivation level] -> ShowS)
-> Show (ErrInvalidDerivationIndex derivation level)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (derivation :: DerivationType) (level :: Depth).
Int -> ErrInvalidDerivationIndex derivation level -> ShowS
forall (derivation :: DerivationType) (level :: Depth).
[ErrInvalidDerivationIndex derivation level] -> ShowS
forall (derivation :: DerivationType) (level :: Depth).
ErrInvalidDerivationIndex derivation level -> String
showList :: [ErrInvalidDerivationIndex derivation level] -> ShowS
$cshowList :: forall (derivation :: DerivationType) (level :: Depth).
[ErrInvalidDerivationIndex derivation level] -> ShowS
show :: ErrInvalidDerivationIndex derivation level -> String
$cshow :: forall (derivation :: DerivationType) (level :: Depth).
ErrInvalidDerivationIndex derivation level -> String
showsPrec :: Int -> ErrInvalidDerivationIndex derivation level -> ShowS
$cshowsPrec :: forall (derivation :: DerivationType) (level :: Depth).
Int -> ErrInvalidDerivationIndex derivation level -> ShowS
Show)

-- | Errors that can occur when listing UTxO statistics.
newtype ErrListUTxOStatistics
    = ErrListUTxOStatisticsNoSuchWallet ErrNoSuchWallet
    deriving (Int -> ErrListUTxOStatistics -> ShowS
[ErrListUTxOStatistics] -> ShowS
ErrListUTxOStatistics -> String
(Int -> ErrListUTxOStatistics -> ShowS)
-> (ErrListUTxOStatistics -> String)
-> ([ErrListUTxOStatistics] -> ShowS)
-> Show ErrListUTxOStatistics
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrListUTxOStatistics] -> ShowS
$cshowList :: [ErrListUTxOStatistics] -> ShowS
show :: ErrListUTxOStatistics -> String
$cshow :: ErrListUTxOStatistics -> String
showsPrec :: Int -> ErrListUTxOStatistics -> ShowS
$cshowsPrec :: Int -> ErrListUTxOStatistics -> ShowS
Show, ErrListUTxOStatistics -> ErrListUTxOStatistics -> Bool
(ErrListUTxOStatistics -> ErrListUTxOStatistics -> Bool)
-> (ErrListUTxOStatistics -> ErrListUTxOStatistics -> Bool)
-> Eq ErrListUTxOStatistics
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrListUTxOStatistics -> ErrListUTxOStatistics -> Bool
$c/= :: ErrListUTxOStatistics -> ErrListUTxOStatistics -> Bool
== :: ErrListUTxOStatistics -> ErrListUTxOStatistics -> Bool
$c== :: ErrListUTxOStatistics -> ErrListUTxOStatistics -> Bool
Eq)

-- | Errors that can occur when signing a transaction.
data ErrSignPayment
    = ErrSignPaymentMkTx ErrMkTransaction
    | ErrSignPaymentNoSuchWallet ErrNoSuchWallet
    | ErrSignPaymentWithRootKey ErrWithRootKey
    | ErrSignPaymentIncorrectTTL PastHorizonException
    deriving (Int -> ErrSignPayment -> ShowS
[ErrSignPayment] -> ShowS
ErrSignPayment -> String
(Int -> ErrSignPayment -> ShowS)
-> (ErrSignPayment -> String)
-> ([ErrSignPayment] -> ShowS)
-> Show ErrSignPayment
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrSignPayment] -> ShowS
$cshowList :: [ErrSignPayment] -> ShowS
show :: ErrSignPayment -> String
$cshow :: ErrSignPayment -> String
showsPrec :: Int -> ErrSignPayment -> ShowS
$cshowsPrec :: Int -> ErrSignPayment -> ShowS
Show, ErrSignPayment -> ErrSignPayment -> Bool
(ErrSignPayment -> ErrSignPayment -> Bool)
-> (ErrSignPayment -> ErrSignPayment -> Bool) -> Eq ErrSignPayment
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrSignPayment -> ErrSignPayment -> Bool
$c/= :: ErrSignPayment -> ErrSignPayment -> Bool
== :: ErrSignPayment -> ErrSignPayment -> Bool
$c== :: ErrSignPayment -> ErrSignPayment -> Bool
Eq)

-- | Errors that can occur when balancing transaction.
data ErrBalanceTx
    = ErrBalanceTxUpdateError ErrUpdateSealedTx
    | ErrBalanceTxSelectAssets ErrSelectAssets
    | ErrBalanceTxMaxSizeLimitExceeded
    | ErrBalanceTxExistingCollateral
    | ErrBalanceTxExistingTotalCollateral
    | ErrBalanceTxExistingReturnCollateral
    | ErrBalanceTxConflictingNetworks
    | ErrBalanceTxAssignRedeemers ErrAssignRedeemers
    | ErrBalanceTxInternalError ErrBalanceTxInternalError
    | ErrBalanceTxZeroAdaOutput
    | ErrByronTxNotSupported
    deriving (Int -> ErrBalanceTx -> ShowS
[ErrBalanceTx] -> ShowS
ErrBalanceTx -> String
(Int -> ErrBalanceTx -> ShowS)
-> (ErrBalanceTx -> String)
-> ([ErrBalanceTx] -> ShowS)
-> Show ErrBalanceTx
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrBalanceTx] -> ShowS
$cshowList :: [ErrBalanceTx] -> ShowS
show :: ErrBalanceTx -> String
$cshow :: ErrBalanceTx -> String
showsPrec :: Int -> ErrBalanceTx -> ShowS
$cshowsPrec :: Int -> ErrBalanceTx -> ShowS
Show, ErrBalanceTx -> ErrBalanceTx -> Bool
(ErrBalanceTx -> ErrBalanceTx -> Bool)
-> (ErrBalanceTx -> ErrBalanceTx -> Bool) -> Eq ErrBalanceTx
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrBalanceTx -> ErrBalanceTx -> Bool
$c/= :: ErrBalanceTx -> ErrBalanceTx -> Bool
== :: ErrBalanceTx -> ErrBalanceTx -> Bool
$c== :: ErrBalanceTx -> ErrBalanceTx -> Bool
Eq)

data ErrBalanceTxInternalError
    = ErrUnderestimatedFee Coin SealedTx
    | ErrFailedBalancing Cardano.Value
    deriving (Int -> ErrBalanceTxInternalError -> ShowS
[ErrBalanceTxInternalError] -> ShowS
ErrBalanceTxInternalError -> String
(Int -> ErrBalanceTxInternalError -> ShowS)
-> (ErrBalanceTxInternalError -> String)
-> ([ErrBalanceTxInternalError] -> ShowS)
-> Show ErrBalanceTxInternalError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrBalanceTxInternalError] -> ShowS
$cshowList :: [ErrBalanceTxInternalError] -> ShowS
show :: ErrBalanceTxInternalError -> String
$cshow :: ErrBalanceTxInternalError -> String
showsPrec :: Int -> ErrBalanceTxInternalError -> ShowS
$cshowsPrec :: Int -> ErrBalanceTxInternalError -> ShowS
Show, ErrBalanceTxInternalError -> ErrBalanceTxInternalError -> Bool
(ErrBalanceTxInternalError -> ErrBalanceTxInternalError -> Bool)
-> (ErrBalanceTxInternalError -> ErrBalanceTxInternalError -> Bool)
-> Eq ErrBalanceTxInternalError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrBalanceTxInternalError -> ErrBalanceTxInternalError -> Bool
$c/= :: ErrBalanceTxInternalError -> ErrBalanceTxInternalError -> Bool
== :: ErrBalanceTxInternalError -> ErrBalanceTxInternalError -> Bool
$c== :: ErrBalanceTxInternalError -> ErrBalanceTxInternalError -> Bool
Eq)

-- | Errors that can occur when submitting a transaction.
data ErrSubmitTransaction
    = ErrSubmitTransactionNoSuchWallet ErrNoSuchWallet
    | ErrSubmitTransactionForeignWallet
    | ErrSubmitTransactionPartiallySignedOrNoSignedTx Int Int
    | ErrSubmitTransactionMultidelegationNotSupported
    deriving (Int -> ErrSubmitTransaction -> ShowS
[ErrSubmitTransaction] -> ShowS
ErrSubmitTransaction -> String
(Int -> ErrSubmitTransaction -> ShowS)
-> (ErrSubmitTransaction -> String)
-> ([ErrSubmitTransaction] -> ShowS)
-> Show ErrSubmitTransaction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrSubmitTransaction] -> ShowS
$cshowList :: [ErrSubmitTransaction] -> ShowS
show :: ErrSubmitTransaction -> String
$cshow :: ErrSubmitTransaction -> String
showsPrec :: Int -> ErrSubmitTransaction -> ShowS
$cshowsPrec :: Int -> ErrSubmitTransaction -> ShowS
Show, ErrSubmitTransaction -> ErrSubmitTransaction -> Bool
(ErrSubmitTransaction -> ErrSubmitTransaction -> Bool)
-> (ErrSubmitTransaction -> ErrSubmitTransaction -> Bool)
-> Eq ErrSubmitTransaction
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrSubmitTransaction -> ErrSubmitTransaction -> Bool
$c/= :: ErrSubmitTransaction -> ErrSubmitTransaction -> Bool
== :: ErrSubmitTransaction -> ErrSubmitTransaction -> Bool
$c== :: ErrSubmitTransaction -> ErrSubmitTransaction -> Bool
Eq)

-- | Errors that can occur when constructing an unsigned transaction.
data ErrConstructTx
    = ErrConstructTxWrongPayload
    | ErrConstructTxBody ErrMkTransaction
    | ErrConstructTxNoSuchWallet ErrNoSuchWallet
    | ErrConstructTxReadRewardAccount ErrReadRewardAccount
    | ErrConstructTxIncorrectTTL PastHorizonException
    | ErrConstructTxMultidelegationNotSupported
    | ErrConstructTxMultiaccountNotSupported
    | ErrConstructTxWrongMintingBurningTemplate
    | ErrConstructTxAssetNameTooLong
    | ErrConstructTxMintOrBurnAssetQuantityOutOfBounds
    | ErrConstructTxWrongValidityBounds
    | ErrConstructTxValidityIntervalNotWithinScriptTimelock
    | ErrConstructTxSharedWalletPending
    | ErrConstructTxNotImplemented String
    -- ^ Temporary error constructor.
    deriving (Int -> ErrConstructTx -> ShowS
[ErrConstructTx] -> ShowS
ErrConstructTx -> String
(Int -> ErrConstructTx -> ShowS)
-> (ErrConstructTx -> String)
-> ([ErrConstructTx] -> ShowS)
-> Show ErrConstructTx
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrConstructTx] -> ShowS
$cshowList :: [ErrConstructTx] -> ShowS
show :: ErrConstructTx -> String
$cshow :: ErrConstructTx -> String
showsPrec :: Int -> ErrConstructTx -> ShowS
$cshowsPrec :: Int -> ErrConstructTx -> ShowS
Show, ErrConstructTx -> ErrConstructTx -> Bool
(ErrConstructTx -> ErrConstructTx -> Bool)
-> (ErrConstructTx -> ErrConstructTx -> Bool) -> Eq ErrConstructTx
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrConstructTx -> ErrConstructTx -> Bool
$c/= :: ErrConstructTx -> ErrConstructTx -> Bool
== :: ErrConstructTx -> ErrConstructTx -> Bool
$c== :: ErrConstructTx -> ErrConstructTx -> Bool
Eq)

-- | Errors that can occur when getting policy id.
data ErrGetPolicyId
    = ErrGetPolicyIdReadPolicyPubliKey ErrReadPolicyPublicKey
    | ErrGetPolicyIdWrongMintingBurningTemplate
    deriving (Int -> ErrGetPolicyId -> ShowS
[ErrGetPolicyId] -> ShowS
ErrGetPolicyId -> String
(Int -> ErrGetPolicyId -> ShowS)
-> (ErrGetPolicyId -> String)
-> ([ErrGetPolicyId] -> ShowS)
-> Show ErrGetPolicyId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrGetPolicyId] -> ShowS
$cshowList :: [ErrGetPolicyId] -> ShowS
show :: ErrGetPolicyId -> String
$cshow :: ErrGetPolicyId -> String
showsPrec :: Int -> ErrGetPolicyId -> ShowS
$cshowsPrec :: Int -> ErrGetPolicyId -> ShowS
Show, ErrGetPolicyId -> ErrGetPolicyId -> Bool
(ErrGetPolicyId -> ErrGetPolicyId -> Bool)
-> (ErrGetPolicyId -> ErrGetPolicyId -> Bool) -> Eq ErrGetPolicyId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrGetPolicyId -> ErrGetPolicyId -> Bool
$c/= :: ErrGetPolicyId -> ErrGetPolicyId -> Bool
== :: ErrGetPolicyId -> ErrGetPolicyId -> Bool
$c== :: ErrGetPolicyId -> ErrGetPolicyId -> Bool
Eq)

newtype ErrMintBurnAssets
    = ErrMintBurnNotImplemented T.Text
      -- ^ Temporary error constructor.
    deriving (Int -> ErrMintBurnAssets -> ShowS
[ErrMintBurnAssets] -> ShowS
ErrMintBurnAssets -> String
(Int -> ErrMintBurnAssets -> ShowS)
-> (ErrMintBurnAssets -> String)
-> ([ErrMintBurnAssets] -> ShowS)
-> Show ErrMintBurnAssets
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrMintBurnAssets] -> ShowS
$cshowList :: [ErrMintBurnAssets] -> ShowS
show :: ErrMintBurnAssets -> String
$cshow :: ErrMintBurnAssets -> String
showsPrec :: Int -> ErrMintBurnAssets -> ShowS
$cshowsPrec :: Int -> ErrMintBurnAssets -> ShowS
Show, ErrMintBurnAssets -> ErrMintBurnAssets -> Bool
(ErrMintBurnAssets -> ErrMintBurnAssets -> Bool)
-> (ErrMintBurnAssets -> ErrMintBurnAssets -> Bool)
-> Eq ErrMintBurnAssets
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrMintBurnAssets -> ErrMintBurnAssets -> Bool
$c/= :: ErrMintBurnAssets -> ErrMintBurnAssets -> Bool
== :: ErrMintBurnAssets -> ErrMintBurnAssets -> Bool
$c== :: ErrMintBurnAssets -> ErrMintBurnAssets -> Bool
Eq)

-- | Errors that can occur when signing a transaction.
data ErrWitnessTx
    = ErrWitnessTxSignTx ErrSignTx
    | ErrWitnessTxNoSuchWallet ErrNoSuchWallet
    | ErrWitnessTxWithRootKey ErrWithRootKey
    | ErrWitnessTxIncorrectTTL PastHorizonException
    deriving (Int -> ErrWitnessTx -> ShowS
[ErrWitnessTx] -> ShowS
ErrWitnessTx -> String
(Int -> ErrWitnessTx -> ShowS)
-> (ErrWitnessTx -> String)
-> ([ErrWitnessTx] -> ShowS)
-> Show ErrWitnessTx
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrWitnessTx] -> ShowS
$cshowList :: [ErrWitnessTx] -> ShowS
show :: ErrWitnessTx -> String
$cshow :: ErrWitnessTx -> String
showsPrec :: Int -> ErrWitnessTx -> ShowS
$cshowsPrec :: Int -> ErrWitnessTx -> ShowS
Show, ErrWitnessTx -> ErrWitnessTx -> Bool
(ErrWitnessTx -> ErrWitnessTx -> Bool)
-> (ErrWitnessTx -> ErrWitnessTx -> Bool) -> Eq ErrWitnessTx
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrWitnessTx -> ErrWitnessTx -> Bool
$c/= :: ErrWitnessTx -> ErrWitnessTx -> Bool
== :: ErrWitnessTx -> ErrWitnessTx -> Bool
$c== :: ErrWitnessTx -> ErrWitnessTx -> Bool
Eq)

-- | Errors that can occur when decoding a transaction.
newtype ErrDecodeTx
    = ErrDecodeTxNoSuchWallet ErrNoSuchWallet
    deriving (Int -> ErrDecodeTx -> ShowS
[ErrDecodeTx] -> ShowS
ErrDecodeTx -> String
(Int -> ErrDecodeTx -> ShowS)
-> (ErrDecodeTx -> String)
-> ([ErrDecodeTx] -> ShowS)
-> Show ErrDecodeTx
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrDecodeTx] -> ShowS
$cshowList :: [ErrDecodeTx] -> ShowS
show :: ErrDecodeTx -> String
$cshow :: ErrDecodeTx -> String
showsPrec :: Int -> ErrDecodeTx -> ShowS
$cshowsPrec :: Int -> ErrDecodeTx -> ShowS
Show, ErrDecodeTx -> ErrDecodeTx -> Bool
(ErrDecodeTx -> ErrDecodeTx -> Bool)
-> (ErrDecodeTx -> ErrDecodeTx -> Bool) -> Eq ErrDecodeTx
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrDecodeTx -> ErrDecodeTx -> Bool
$c/= :: ErrDecodeTx -> ErrDecodeTx -> Bool
== :: ErrDecodeTx -> ErrDecodeTx -> Bool
$c== :: ErrDecodeTx -> ErrDecodeTx -> Bool
Eq)

-- | Errors that can occur when submitting a signed transaction to the network.
data ErrSubmitTx
    = ErrSubmitTxNetwork ErrPostTx
    | ErrSubmitTxNoSuchWallet ErrNoSuchWallet
    | ErrSubmitTxImpossible ErrNoSuchTransaction
    deriving (Int -> ErrSubmitTx -> ShowS
[ErrSubmitTx] -> ShowS
ErrSubmitTx -> String
(Int -> ErrSubmitTx -> ShowS)
-> (ErrSubmitTx -> String)
-> ([ErrSubmitTx] -> ShowS)
-> Show ErrSubmitTx
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrSubmitTx] -> ShowS
$cshowList :: [ErrSubmitTx] -> ShowS
show :: ErrSubmitTx -> String
$cshow :: ErrSubmitTx -> String
showsPrec :: Int -> ErrSubmitTx -> ShowS
$cshowsPrec :: Int -> ErrSubmitTx -> ShowS
Show, ErrSubmitTx -> ErrSubmitTx -> Bool
(ErrSubmitTx -> ErrSubmitTx -> Bool)
-> (ErrSubmitTx -> ErrSubmitTx -> Bool) -> Eq ErrSubmitTx
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrSubmitTx -> ErrSubmitTx -> Bool
$c/= :: ErrSubmitTx -> ErrSubmitTx -> Bool
== :: ErrSubmitTx -> ErrSubmitTx -> Bool
$c== :: ErrSubmitTx -> ErrSubmitTx -> Bool
Eq)

-- | Errors that can occur when trying to change a wallet's passphrase.
data ErrUpdatePassphrase
    = ErrUpdatePassphraseNoSuchWallet ErrNoSuchWallet
    | ErrUpdatePassphraseWithRootKey ErrWithRootKey
    deriving (Int -> ErrUpdatePassphrase -> ShowS
[ErrUpdatePassphrase] -> ShowS
ErrUpdatePassphrase -> String
(Int -> ErrUpdatePassphrase -> ShowS)
-> (ErrUpdatePassphrase -> String)
-> ([ErrUpdatePassphrase] -> ShowS)
-> Show ErrUpdatePassphrase
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrUpdatePassphrase] -> ShowS
$cshowList :: [ErrUpdatePassphrase] -> ShowS
show :: ErrUpdatePassphrase -> String
$cshow :: ErrUpdatePassphrase -> String
showsPrec :: Int -> ErrUpdatePassphrase -> ShowS
$cshowsPrec :: Int -> ErrUpdatePassphrase -> ShowS
Show, ErrUpdatePassphrase -> ErrUpdatePassphrase -> Bool
(ErrUpdatePassphrase -> ErrUpdatePassphrase -> Bool)
-> (ErrUpdatePassphrase -> ErrUpdatePassphrase -> Bool)
-> Eq ErrUpdatePassphrase
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrUpdatePassphrase -> ErrUpdatePassphrase -> Bool
$c/= :: ErrUpdatePassphrase -> ErrUpdatePassphrase -> Bool
== :: ErrUpdatePassphrase -> ErrUpdatePassphrase -> Bool
$c== :: ErrUpdatePassphrase -> ErrUpdatePassphrase -> Bool
Eq)

-- | Errors that can occur when trying to perform an operation on a wallet that
-- requires a private key, but where none is attached to the wallet.
data ErrWithRootKey
    = ErrWithRootKeyNoRootKey WalletId
    | ErrWithRootKeyWrongPassphrase WalletId ErrWrongPassphrase
    | ErrWithRootKeyWrongMnemonic WalletId
    deriving (Int -> ErrWithRootKey -> ShowS
[ErrWithRootKey] -> ShowS
ErrWithRootKey -> String
(Int -> ErrWithRootKey -> ShowS)
-> (ErrWithRootKey -> String)
-> ([ErrWithRootKey] -> ShowS)
-> Show ErrWithRootKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrWithRootKey] -> ShowS
$cshowList :: [ErrWithRootKey] -> ShowS
show :: ErrWithRootKey -> String
$cshow :: ErrWithRootKey -> String
showsPrec :: Int -> ErrWithRootKey -> ShowS
$cshowsPrec :: Int -> ErrWithRootKey -> ShowS
Show, ErrWithRootKey -> ErrWithRootKey -> Bool
(ErrWithRootKey -> ErrWithRootKey -> Bool)
-> (ErrWithRootKey -> ErrWithRootKey -> Bool) -> Eq ErrWithRootKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrWithRootKey -> ErrWithRootKey -> Bool
$c/= :: ErrWithRootKey -> ErrWithRootKey -> Bool
== :: ErrWithRootKey -> ErrWithRootKey -> Bool
$c== :: ErrWithRootKey -> ErrWithRootKey -> Bool
Eq)

-- | Errors that can occur when trying to list transactions.
data ErrListTransactions
    = ErrListTransactionsNoSuchWallet ErrNoSuchWallet
    | ErrListTransactionsStartTimeLaterThanEndTime ErrStartTimeLaterThanEndTime
    | ErrListTransactionsMinWithdrawalWrong
    | ErrListTransactionsPastHorizonException PastHorizonException
    deriving (Int -> ErrListTransactions -> ShowS
[ErrListTransactions] -> ShowS
ErrListTransactions -> String
(Int -> ErrListTransactions -> ShowS)
-> (ErrListTransactions -> String)
-> ([ErrListTransactions] -> ShowS)
-> Show ErrListTransactions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrListTransactions] -> ShowS
$cshowList :: [ErrListTransactions] -> ShowS
show :: ErrListTransactions -> String
$cshow :: ErrListTransactions -> String
showsPrec :: Int -> ErrListTransactions -> ShowS
$cshowsPrec :: Int -> ErrListTransactions -> ShowS
Show)

-- | Errors that can occur when trying to get transaction.
data ErrGetTransaction
    = ErrGetTransactionNoSuchWallet ErrNoSuchWallet
    | ErrGetTransactionNoSuchTransaction ErrNoSuchTransaction
    deriving (Int -> ErrGetTransaction -> ShowS
[ErrGetTransaction] -> ShowS
ErrGetTransaction -> String
(Int -> ErrGetTransaction -> ShowS)
-> (ErrGetTransaction -> String)
-> ([ErrGetTransaction] -> ShowS)
-> Show ErrGetTransaction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrGetTransaction] -> ShowS
$cshowList :: [ErrGetTransaction] -> ShowS
show :: ErrGetTransaction -> String
$cshow :: ErrGetTransaction -> String
showsPrec :: Int -> ErrGetTransaction -> ShowS
$cshowsPrec :: Int -> ErrGetTransaction -> ShowS
Show, ErrGetTransaction -> ErrGetTransaction -> Bool
(ErrGetTransaction -> ErrGetTransaction -> Bool)
-> (ErrGetTransaction -> ErrGetTransaction -> Bool)
-> Eq ErrGetTransaction
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrGetTransaction -> ErrGetTransaction -> Bool
$c/= :: ErrGetTransaction -> ErrGetTransaction -> Bool
== :: ErrGetTransaction -> ErrGetTransaction -> Bool
$c== :: ErrGetTransaction -> ErrGetTransaction -> Bool
Eq)

-- | Indicates that the specified start time is later than the specified end
-- time.
data ErrStartTimeLaterThanEndTime = ErrStartTimeLaterThanEndTime
    { ErrStartTimeLaterThanEndTime -> UTCTime
errStartTime :: UTCTime
    , ErrStartTimeLaterThanEndTime -> UTCTime
errEndTime :: UTCTime
    } deriving (Int -> ErrStartTimeLaterThanEndTime -> ShowS
[ErrStartTimeLaterThanEndTime] -> ShowS
ErrStartTimeLaterThanEndTime -> String
(Int -> ErrStartTimeLaterThanEndTime -> ShowS)
-> (ErrStartTimeLaterThanEndTime -> String)
-> ([ErrStartTimeLaterThanEndTime] -> ShowS)
-> Show ErrStartTimeLaterThanEndTime
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrStartTimeLaterThanEndTime] -> ShowS
$cshowList :: [ErrStartTimeLaterThanEndTime] -> ShowS
show :: ErrStartTimeLaterThanEndTime -> String
$cshow :: ErrStartTimeLaterThanEndTime -> String
showsPrec :: Int -> ErrStartTimeLaterThanEndTime -> ShowS
$cshowsPrec :: Int -> ErrStartTimeLaterThanEndTime -> ShowS
Show, ErrStartTimeLaterThanEndTime
-> ErrStartTimeLaterThanEndTime -> Bool
(ErrStartTimeLaterThanEndTime
 -> ErrStartTimeLaterThanEndTime -> Bool)
-> (ErrStartTimeLaterThanEndTime
    -> ErrStartTimeLaterThanEndTime -> Bool)
-> Eq ErrStartTimeLaterThanEndTime
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrStartTimeLaterThanEndTime
-> ErrStartTimeLaterThanEndTime -> Bool
$c/= :: ErrStartTimeLaterThanEndTime
-> ErrStartTimeLaterThanEndTime -> Bool
== :: ErrStartTimeLaterThanEndTime
-> ErrStartTimeLaterThanEndTime -> Bool
$c== :: ErrStartTimeLaterThanEndTime
-> ErrStartTimeLaterThanEndTime -> Bool
Eq)

data ErrCreateMigrationPlan
    = ErrCreateMigrationPlanEmpty
    | ErrCreateMigrationPlanNoSuchWallet ErrNoSuchWallet
    deriving ((forall x. ErrCreateMigrationPlan -> Rep ErrCreateMigrationPlan x)
-> (forall x.
    Rep ErrCreateMigrationPlan x -> ErrCreateMigrationPlan)
-> Generic ErrCreateMigrationPlan
forall x. Rep ErrCreateMigrationPlan x -> ErrCreateMigrationPlan
forall x. ErrCreateMigrationPlan -> Rep ErrCreateMigrationPlan x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ErrCreateMigrationPlan x -> ErrCreateMigrationPlan
$cfrom :: forall x. ErrCreateMigrationPlan -> Rep ErrCreateMigrationPlan x
Generic, ErrCreateMigrationPlan -> ErrCreateMigrationPlan -> Bool
(ErrCreateMigrationPlan -> ErrCreateMigrationPlan -> Bool)
-> (ErrCreateMigrationPlan -> ErrCreateMigrationPlan -> Bool)
-> Eq ErrCreateMigrationPlan
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrCreateMigrationPlan -> ErrCreateMigrationPlan -> Bool
$c/= :: ErrCreateMigrationPlan -> ErrCreateMigrationPlan -> Bool
== :: ErrCreateMigrationPlan -> ErrCreateMigrationPlan -> Bool
$c== :: ErrCreateMigrationPlan -> ErrCreateMigrationPlan -> Bool
Eq, Int -> ErrCreateMigrationPlan -> ShowS
[ErrCreateMigrationPlan] -> ShowS
ErrCreateMigrationPlan -> String
(Int -> ErrCreateMigrationPlan -> ShowS)
-> (ErrCreateMigrationPlan -> String)
-> ([ErrCreateMigrationPlan] -> ShowS)
-> Show ErrCreateMigrationPlan
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrCreateMigrationPlan] -> ShowS
$cshowList :: [ErrCreateMigrationPlan] -> ShowS
show :: ErrCreateMigrationPlan -> String
$cshow :: ErrCreateMigrationPlan -> String
showsPrec :: Int -> ErrCreateMigrationPlan -> ShowS
$cshowsPrec :: Int -> ErrCreateMigrationPlan -> ShowS
Show)

data ErrSelectAssets
    = ErrSelectAssetsPrepareOutputsError
        (SelectionOutputError WalletSelectionContext)
    | ErrSelectAssetsNoSuchWallet ErrNoSuchWallet
    | ErrSelectAssetsAlreadyWithdrawing Tx
    | ErrSelectAssetsSelectionError (SelectionError WalletSelectionContext)
    deriving ((forall x. ErrSelectAssets -> Rep ErrSelectAssets x)
-> (forall x. Rep ErrSelectAssets x -> ErrSelectAssets)
-> Generic ErrSelectAssets
forall x. Rep ErrSelectAssets x -> ErrSelectAssets
forall x. ErrSelectAssets -> Rep ErrSelectAssets x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ErrSelectAssets x -> ErrSelectAssets
$cfrom :: forall x. ErrSelectAssets -> Rep ErrSelectAssets x
Generic, ErrSelectAssets -> ErrSelectAssets -> Bool
(ErrSelectAssets -> ErrSelectAssets -> Bool)
-> (ErrSelectAssets -> ErrSelectAssets -> Bool)
-> Eq ErrSelectAssets
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrSelectAssets -> ErrSelectAssets -> Bool
$c/= :: ErrSelectAssets -> ErrSelectAssets -> Bool
== :: ErrSelectAssets -> ErrSelectAssets -> Bool
$c== :: ErrSelectAssets -> ErrSelectAssets -> Bool
Eq, Int -> ErrSelectAssets -> ShowS
[ErrSelectAssets] -> ShowS
ErrSelectAssets -> String
(Int -> ErrSelectAssets -> ShowS)
-> (ErrSelectAssets -> String)
-> ([ErrSelectAssets] -> ShowS)
-> Show ErrSelectAssets
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrSelectAssets] -> ShowS
$cshowList :: [ErrSelectAssets] -> ShowS
show :: ErrSelectAssets -> String
$cshow :: ErrSelectAssets -> String
showsPrec :: Int -> ErrSelectAssets -> ShowS
$cshowsPrec :: Int -> ErrSelectAssets -> ShowS
Show)

data ErrStakePoolDelegation
    = ErrStakePoolDelegationNoSuchWallet ErrNoSuchWallet
    | ErrStakePoolJoin ErrCannotJoin
    | ErrStakePoolQuit ErrCannotQuit

-- | Errors that can occur when fetching the reward balance of a wallet
newtype ErrFetchRewards
    = ErrFetchRewardsReadRewardAccount ErrReadRewardAccount
    deriving ((forall x. ErrFetchRewards -> Rep ErrFetchRewards x)
-> (forall x. Rep ErrFetchRewards x -> ErrFetchRewards)
-> Generic ErrFetchRewards
forall x. Rep ErrFetchRewards x -> ErrFetchRewards
forall x. ErrFetchRewards -> Rep ErrFetchRewards x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ErrFetchRewards x -> ErrFetchRewards
$cfrom :: forall x. ErrFetchRewards -> Rep ErrFetchRewards x
Generic, ErrFetchRewards -> ErrFetchRewards -> Bool
(ErrFetchRewards -> ErrFetchRewards -> Bool)
-> (ErrFetchRewards -> ErrFetchRewards -> Bool)
-> Eq ErrFetchRewards
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrFetchRewards -> ErrFetchRewards -> Bool
$c/= :: ErrFetchRewards -> ErrFetchRewards -> Bool
== :: ErrFetchRewards -> ErrFetchRewards -> Bool
$c== :: ErrFetchRewards -> ErrFetchRewards -> Bool
Eq, Int -> ErrFetchRewards -> ShowS
[ErrFetchRewards] -> ShowS
ErrFetchRewards -> String
(Int -> ErrFetchRewards -> ShowS)
-> (ErrFetchRewards -> String)
-> ([ErrFetchRewards] -> ShowS)
-> Show ErrFetchRewards
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrFetchRewards] -> ShowS
$cshowList :: [ErrFetchRewards] -> ShowS
show :: ErrFetchRewards -> String
$cshow :: ErrFetchRewards -> String
showsPrec :: Int -> ErrFetchRewards -> ShowS
$cshowsPrec :: Int -> ErrFetchRewards -> ShowS
Show)

data ErrCheckWalletIntegrity
    = ErrCheckWalletIntegrityNoSuchWallet ErrNoSuchWallet
    | ErrCheckIntegrityDifferentGenesis (Hash "Genesis") (Hash "Genesis")
    deriving (ErrCheckWalletIntegrity -> ErrCheckWalletIntegrity -> Bool
(ErrCheckWalletIntegrity -> ErrCheckWalletIntegrity -> Bool)
-> (ErrCheckWalletIntegrity -> ErrCheckWalletIntegrity -> Bool)
-> Eq ErrCheckWalletIntegrity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrCheckWalletIntegrity -> ErrCheckWalletIntegrity -> Bool
$c/= :: ErrCheckWalletIntegrity -> ErrCheckWalletIntegrity -> Bool
== :: ErrCheckWalletIntegrity -> ErrCheckWalletIntegrity -> Bool
$c== :: ErrCheckWalletIntegrity -> ErrCheckWalletIntegrity -> Bool
Eq, Int -> ErrCheckWalletIntegrity -> ShowS
[ErrCheckWalletIntegrity] -> ShowS
ErrCheckWalletIntegrity -> String
(Int -> ErrCheckWalletIntegrity -> ShowS)
-> (ErrCheckWalletIntegrity -> String)
-> ([ErrCheckWalletIntegrity] -> ShowS)
-> Show ErrCheckWalletIntegrity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrCheckWalletIntegrity] -> ShowS
$cshowList :: [ErrCheckWalletIntegrity] -> ShowS
show :: ErrCheckWalletIntegrity -> String
$cshow :: ErrCheckWalletIntegrity -> String
showsPrec :: Int -> ErrCheckWalletIntegrity -> ShowS
$cshowsPrec :: Int -> ErrCheckWalletIntegrity -> ShowS
Show)

instance Exception ErrCheckWalletIntegrity

-- | Can't perform given operation because the wallet died.
newtype ErrWalletNotResponding
    = ErrWalletNotResponding WalletId
    deriving (ErrWalletNotResponding -> ErrWalletNotResponding -> Bool
(ErrWalletNotResponding -> ErrWalletNotResponding -> Bool)
-> (ErrWalletNotResponding -> ErrWalletNotResponding -> Bool)
-> Eq ErrWalletNotResponding
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrWalletNotResponding -> ErrWalletNotResponding -> Bool
$c/= :: ErrWalletNotResponding -> ErrWalletNotResponding -> Bool
== :: ErrWalletNotResponding -> ErrWalletNotResponding -> Bool
$c== :: ErrWalletNotResponding -> ErrWalletNotResponding -> Bool
Eq, Int -> ErrWalletNotResponding -> ShowS
[ErrWalletNotResponding] -> ShowS
ErrWalletNotResponding -> String
(Int -> ErrWalletNotResponding -> ShowS)
-> (ErrWalletNotResponding -> String)
-> ([ErrWalletNotResponding] -> ShowS)
-> Show ErrWalletNotResponding
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrWalletNotResponding] -> ShowS
$cshowList :: [ErrWalletNotResponding] -> ShowS
show :: ErrWalletNotResponding -> String
$cshow :: ErrWalletNotResponding -> String
showsPrec :: Int -> ErrWalletNotResponding -> ShowS
$cshowsPrec :: Int -> ErrWalletNotResponding -> ShowS
Show)

data ErrCreateRandomAddress
    = ErrIndexAlreadyExists (Index 'Hardened 'AddressK)
    | ErrCreateAddrNoSuchWallet ErrNoSuchWallet
    | ErrCreateAddrWithRootKey ErrWithRootKey
    | ErrCreateAddressNotAByronWallet
    deriving ((forall x. ErrCreateRandomAddress -> Rep ErrCreateRandomAddress x)
-> (forall x.
    Rep ErrCreateRandomAddress x -> ErrCreateRandomAddress)
-> Generic ErrCreateRandomAddress
forall x. Rep ErrCreateRandomAddress x -> ErrCreateRandomAddress
forall x. ErrCreateRandomAddress -> Rep ErrCreateRandomAddress x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ErrCreateRandomAddress x -> ErrCreateRandomAddress
$cfrom :: forall x. ErrCreateRandomAddress -> Rep ErrCreateRandomAddress x
Generic, ErrCreateRandomAddress -> ErrCreateRandomAddress -> Bool
(ErrCreateRandomAddress -> ErrCreateRandomAddress -> Bool)
-> (ErrCreateRandomAddress -> ErrCreateRandomAddress -> Bool)
-> Eq ErrCreateRandomAddress
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrCreateRandomAddress -> ErrCreateRandomAddress -> Bool
$c/= :: ErrCreateRandomAddress -> ErrCreateRandomAddress -> Bool
== :: ErrCreateRandomAddress -> ErrCreateRandomAddress -> Bool
$c== :: ErrCreateRandomAddress -> ErrCreateRandomAddress -> Bool
Eq, Int -> ErrCreateRandomAddress -> ShowS
[ErrCreateRandomAddress] -> ShowS
ErrCreateRandomAddress -> String
(Int -> ErrCreateRandomAddress -> ShowS)
-> (ErrCreateRandomAddress -> String)
-> ([ErrCreateRandomAddress] -> ShowS)
-> Show ErrCreateRandomAddress
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrCreateRandomAddress] -> ShowS
$cshowList :: [ErrCreateRandomAddress] -> ShowS
show :: ErrCreateRandomAddress -> String
$cshow :: ErrCreateRandomAddress -> String
showsPrec :: Int -> ErrCreateRandomAddress -> ShowS
$cshowsPrec :: Int -> ErrCreateRandomAddress -> ShowS
Show)

data ErrImportRandomAddress
    = ErrImportAddrNoSuchWallet ErrNoSuchWallet
    | ErrImportAddr ErrImportAddress
    | ErrImportAddressNotAByronWallet
    deriving ((forall x. ErrImportRandomAddress -> Rep ErrImportRandomAddress x)
-> (forall x.
    Rep ErrImportRandomAddress x -> ErrImportRandomAddress)
-> Generic ErrImportRandomAddress
forall x. Rep ErrImportRandomAddress x -> ErrImportRandomAddress
forall x. ErrImportRandomAddress -> Rep ErrImportRandomAddress x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ErrImportRandomAddress x -> ErrImportRandomAddress
$cfrom :: forall x. ErrImportRandomAddress -> Rep ErrImportRandomAddress x
Generic, ErrImportRandomAddress -> ErrImportRandomAddress -> Bool
(ErrImportRandomAddress -> ErrImportRandomAddress -> Bool)
-> (ErrImportRandomAddress -> ErrImportRandomAddress -> Bool)
-> Eq ErrImportRandomAddress
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrImportRandomAddress -> ErrImportRandomAddress -> Bool
$c/= :: ErrImportRandomAddress -> ErrImportRandomAddress -> Bool
== :: ErrImportRandomAddress -> ErrImportRandomAddress -> Bool
$c== :: ErrImportRandomAddress -> ErrImportRandomAddress -> Bool
Eq, Int -> ErrImportRandomAddress -> ShowS
[ErrImportRandomAddress] -> ShowS
ErrImportRandomAddress -> String
(Int -> ErrImportRandomAddress -> ShowS)
-> (ErrImportRandomAddress -> String)
-> ([ErrImportRandomAddress] -> ShowS)
-> Show ErrImportRandomAddress
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrImportRandomAddress] -> ShowS
$cshowList :: [ErrImportRandomAddress] -> ShowS
show :: ErrImportRandomAddress -> String
$cshow :: ErrImportRandomAddress -> String
showsPrec :: Int -> ErrImportRandomAddress -> ShowS
$cshowsPrec :: Int -> ErrImportRandomAddress -> ShowS
Show)

data ErrNotASequentialWallet
    = ErrNotASequentialWallet
    deriving ((forall x.
 ErrNotASequentialWallet -> Rep ErrNotASequentialWallet x)
-> (forall x.
    Rep ErrNotASequentialWallet x -> ErrNotASequentialWallet)
-> Generic ErrNotASequentialWallet
forall x. Rep ErrNotASequentialWallet x -> ErrNotASequentialWallet
forall x. ErrNotASequentialWallet -> Rep ErrNotASequentialWallet x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ErrNotASequentialWallet x -> ErrNotASequentialWallet
$cfrom :: forall x. ErrNotASequentialWallet -> Rep ErrNotASequentialWallet x
Generic, ErrNotASequentialWallet -> ErrNotASequentialWallet -> Bool
(ErrNotASequentialWallet -> ErrNotASequentialWallet -> Bool)
-> (ErrNotASequentialWallet -> ErrNotASequentialWallet -> Bool)
-> Eq ErrNotASequentialWallet
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrNotASequentialWallet -> ErrNotASequentialWallet -> Bool
$c/= :: ErrNotASequentialWallet -> ErrNotASequentialWallet -> Bool
== :: ErrNotASequentialWallet -> ErrNotASequentialWallet -> Bool
$c== :: ErrNotASequentialWallet -> ErrNotASequentialWallet -> Bool
Eq, Int -> ErrNotASequentialWallet -> ShowS
[ErrNotASequentialWallet] -> ShowS
ErrNotASequentialWallet -> String
(Int -> ErrNotASequentialWallet -> ShowS)
-> (ErrNotASequentialWallet -> String)
-> ([ErrNotASequentialWallet] -> ShowS)
-> Show ErrNotASequentialWallet
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrNotASequentialWallet] -> ShowS
$cshowList :: [ErrNotASequentialWallet] -> ShowS
show :: ErrNotASequentialWallet -> String
$cshow :: ErrNotASequentialWallet -> String
showsPrec :: Int -> ErrNotASequentialWallet -> ShowS
$cshowsPrec :: Int -> ErrNotASequentialWallet -> ShowS
Show)

data ErrReadRewardAccount
    = ErrReadRewardAccountNotAShelleyWallet
    | ErrReadRewardAccountNoSuchWallet ErrNoSuchWallet
    deriving ((forall x. ErrReadRewardAccount -> Rep ErrReadRewardAccount x)
-> (forall x. Rep ErrReadRewardAccount x -> ErrReadRewardAccount)
-> Generic ErrReadRewardAccount
forall x. Rep ErrReadRewardAccount x -> ErrReadRewardAccount
forall x. ErrReadRewardAccount -> Rep ErrReadRewardAccount x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ErrReadRewardAccount x -> ErrReadRewardAccount
$cfrom :: forall x. ErrReadRewardAccount -> Rep ErrReadRewardAccount x
Generic, ErrReadRewardAccount -> ErrReadRewardAccount -> Bool
(ErrReadRewardAccount -> ErrReadRewardAccount -> Bool)
-> (ErrReadRewardAccount -> ErrReadRewardAccount -> Bool)
-> Eq ErrReadRewardAccount
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrReadRewardAccount -> ErrReadRewardAccount -> Bool
$c/= :: ErrReadRewardAccount -> ErrReadRewardAccount -> Bool
== :: ErrReadRewardAccount -> ErrReadRewardAccount -> Bool
$c== :: ErrReadRewardAccount -> ErrReadRewardAccount -> Bool
Eq, Int -> ErrReadRewardAccount -> ShowS
[ErrReadRewardAccount] -> ShowS
ErrReadRewardAccount -> String
(Int -> ErrReadRewardAccount -> ShowS)
-> (ErrReadRewardAccount -> String)
-> ([ErrReadRewardAccount] -> ShowS)
-> Show ErrReadRewardAccount
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrReadRewardAccount] -> ShowS
$cshowList :: [ErrReadRewardAccount] -> ShowS
show :: ErrReadRewardAccount -> String
$cshow :: ErrReadRewardAccount -> String
showsPrec :: Int -> ErrReadRewardAccount -> ShowS
$cshowsPrec :: Int -> ErrReadRewardAccount -> ShowS
Show)

data ErrWithdrawalNotWorth
    = ErrWithdrawalNotWorth
    deriving ((forall x. ErrWithdrawalNotWorth -> Rep ErrWithdrawalNotWorth x)
-> (forall x. Rep ErrWithdrawalNotWorth x -> ErrWithdrawalNotWorth)
-> Generic ErrWithdrawalNotWorth
forall x. Rep ErrWithdrawalNotWorth x -> ErrWithdrawalNotWorth
forall x. ErrWithdrawalNotWorth -> Rep ErrWithdrawalNotWorth x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ErrWithdrawalNotWorth x -> ErrWithdrawalNotWorth
$cfrom :: forall x. ErrWithdrawalNotWorth -> Rep ErrWithdrawalNotWorth x
Generic, ErrWithdrawalNotWorth -> ErrWithdrawalNotWorth -> Bool
(ErrWithdrawalNotWorth -> ErrWithdrawalNotWorth -> Bool)
-> (ErrWithdrawalNotWorth -> ErrWithdrawalNotWorth -> Bool)
-> Eq ErrWithdrawalNotWorth
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrWithdrawalNotWorth -> ErrWithdrawalNotWorth -> Bool
$c/= :: ErrWithdrawalNotWorth -> ErrWithdrawalNotWorth -> Bool
== :: ErrWithdrawalNotWorth -> ErrWithdrawalNotWorth -> Bool
$c== :: ErrWithdrawalNotWorth -> ErrWithdrawalNotWorth -> Bool
Eq, Int -> ErrWithdrawalNotWorth -> ShowS
[ErrWithdrawalNotWorth] -> ShowS
ErrWithdrawalNotWorth -> String
(Int -> ErrWithdrawalNotWorth -> ShowS)
-> (ErrWithdrawalNotWorth -> String)
-> ([ErrWithdrawalNotWorth] -> ShowS)
-> Show ErrWithdrawalNotWorth
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrWithdrawalNotWorth] -> ShowS
$cshowList :: [ErrWithdrawalNotWorth] -> ShowS
show :: ErrWithdrawalNotWorth -> String
$cshow :: ErrWithdrawalNotWorth -> String
showsPrec :: Int -> ErrWithdrawalNotWorth -> ShowS
$cshowsPrec :: Int -> ErrWithdrawalNotWorth -> ShowS
Show)

data ErrReadPolicyPublicKey
    = ErrReadPolicyPublicKeyNotAShelleyWallet
    | ErrReadPolicyPublicKeyNoSuchWallet ErrNoSuchWallet
    | ErrReadPolicyPublicKeyAbsent
    deriving ((forall x. ErrReadPolicyPublicKey -> Rep ErrReadPolicyPublicKey x)
-> (forall x.
    Rep ErrReadPolicyPublicKey x -> ErrReadPolicyPublicKey)
-> Generic ErrReadPolicyPublicKey
forall x. Rep ErrReadPolicyPublicKey x -> ErrReadPolicyPublicKey
forall x. ErrReadPolicyPublicKey -> Rep ErrReadPolicyPublicKey x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ErrReadPolicyPublicKey x -> ErrReadPolicyPublicKey
$cfrom :: forall x. ErrReadPolicyPublicKey -> Rep ErrReadPolicyPublicKey x
Generic, ErrReadPolicyPublicKey -> ErrReadPolicyPublicKey -> Bool
(ErrReadPolicyPublicKey -> ErrReadPolicyPublicKey -> Bool)
-> (ErrReadPolicyPublicKey -> ErrReadPolicyPublicKey -> Bool)
-> Eq ErrReadPolicyPublicKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrReadPolicyPublicKey -> ErrReadPolicyPublicKey -> Bool
$c/= :: ErrReadPolicyPublicKey -> ErrReadPolicyPublicKey -> Bool
== :: ErrReadPolicyPublicKey -> ErrReadPolicyPublicKey -> Bool
$c== :: ErrReadPolicyPublicKey -> ErrReadPolicyPublicKey -> Bool
Eq, Int -> ErrReadPolicyPublicKey -> ShowS
[ErrReadPolicyPublicKey] -> ShowS
ErrReadPolicyPublicKey -> String
(Int -> ErrReadPolicyPublicKey -> ShowS)
-> (ErrReadPolicyPublicKey -> String)
-> ([ErrReadPolicyPublicKey] -> ShowS)
-> Show ErrReadPolicyPublicKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrReadPolicyPublicKey] -> ShowS
$cshowList :: [ErrReadPolicyPublicKey] -> ShowS
show :: ErrReadPolicyPublicKey -> String
$cshow :: ErrReadPolicyPublicKey -> String
showsPrec :: Int -> ErrReadPolicyPublicKey -> ShowS
$cshowsPrec :: Int -> ErrReadPolicyPublicKey -> ShowS
Show)

data ErrWritePolicyPublicKey
    = ErrWritePolicyPublicKeyNoSuchWallet ErrNoSuchWallet
    | ErrWritePolicyPublicKeyWithRootKey ErrWithRootKey
    deriving ((forall x.
 ErrWritePolicyPublicKey -> Rep ErrWritePolicyPublicKey x)
-> (forall x.
    Rep ErrWritePolicyPublicKey x -> ErrWritePolicyPublicKey)
-> Generic ErrWritePolicyPublicKey
forall x. Rep ErrWritePolicyPublicKey x -> ErrWritePolicyPublicKey
forall x. ErrWritePolicyPublicKey -> Rep ErrWritePolicyPublicKey x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ErrWritePolicyPublicKey x -> ErrWritePolicyPublicKey
$cfrom :: forall x. ErrWritePolicyPublicKey -> Rep ErrWritePolicyPublicKey x
Generic, ErrWritePolicyPublicKey -> ErrWritePolicyPublicKey -> Bool
(ErrWritePolicyPublicKey -> ErrWritePolicyPublicKey -> Bool)
-> (ErrWritePolicyPublicKey -> ErrWritePolicyPublicKey -> Bool)
-> Eq ErrWritePolicyPublicKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrWritePolicyPublicKey -> ErrWritePolicyPublicKey -> Bool
$c/= :: ErrWritePolicyPublicKey -> ErrWritePolicyPublicKey -> Bool
== :: ErrWritePolicyPublicKey -> ErrWritePolicyPublicKey -> Bool
$c== :: ErrWritePolicyPublicKey -> ErrWritePolicyPublicKey -> Bool
Eq, Int -> ErrWritePolicyPublicKey -> ShowS
[ErrWritePolicyPublicKey] -> ShowS
ErrWritePolicyPublicKey -> String
(Int -> ErrWritePolicyPublicKey -> ShowS)
-> (ErrWritePolicyPublicKey -> String)
-> ([ErrWritePolicyPublicKey] -> ShowS)
-> Show ErrWritePolicyPublicKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrWritePolicyPublicKey] -> ShowS
$cshowList :: [ErrWritePolicyPublicKey] -> ShowS
show :: ErrWritePolicyPublicKey -> String
$cshow :: ErrWritePolicyPublicKey -> String
showsPrec :: Int -> ErrWritePolicyPublicKey -> ShowS
$cshowsPrec :: Int -> ErrWritePolicyPublicKey -> ShowS
Show)

{-------------------------------------------------------------------------------
                                   Utils
-------------------------------------------------------------------------------}

withNoSuchWallet
    :: Monad m
    => WalletId
    -> m (Maybe a)
    -> ExceptT ErrNoSuchWallet m a
withNoSuchWallet :: WalletId -> m (Maybe a) -> ExceptT ErrNoSuchWallet m a
withNoSuchWallet WalletId
wid =
    ErrNoSuchWallet -> MaybeT m a -> ExceptT ErrNoSuchWallet m a
forall (m :: * -> *) e a.
Functor m =>
e -> MaybeT m a -> ExceptT e m a
maybeToExceptT (WalletId -> ErrNoSuchWallet
ErrNoSuchWallet WalletId
wid) (MaybeT m a -> ExceptT ErrNoSuchWallet m a)
-> (m (Maybe a) -> MaybeT m a)
-> m (Maybe a)
-> ExceptT ErrNoSuchWallet m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Maybe a) -> MaybeT m a
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT

data PoolRetirementEpochInfo = PoolRetirementEpochInfo
    { PoolRetirementEpochInfo -> EpochNo
currentEpoch
        :: W.EpochNo
        -- ^ The current epoch.
    , PoolRetirementEpochInfo -> EpochNo
retirementEpoch
        :: W.EpochNo
        -- ^ The retirement epoch of a pool.
    }
    deriving (PoolRetirementEpochInfo -> PoolRetirementEpochInfo -> Bool
(PoolRetirementEpochInfo -> PoolRetirementEpochInfo -> Bool)
-> (PoolRetirementEpochInfo -> PoolRetirementEpochInfo -> Bool)
-> Eq PoolRetirementEpochInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PoolRetirementEpochInfo -> PoolRetirementEpochInfo -> Bool
$c/= :: PoolRetirementEpochInfo -> PoolRetirementEpochInfo -> Bool
== :: PoolRetirementEpochInfo -> PoolRetirementEpochInfo -> Bool
$c== :: PoolRetirementEpochInfo -> PoolRetirementEpochInfo -> Bool
Eq, (forall x.
 PoolRetirementEpochInfo -> Rep PoolRetirementEpochInfo x)
-> (forall x.
    Rep PoolRetirementEpochInfo x -> PoolRetirementEpochInfo)
-> Generic PoolRetirementEpochInfo
forall x. Rep PoolRetirementEpochInfo x -> PoolRetirementEpochInfo
forall x. PoolRetirementEpochInfo -> Rep PoolRetirementEpochInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep PoolRetirementEpochInfo x -> PoolRetirementEpochInfo
$cfrom :: forall x. PoolRetirementEpochInfo -> Rep PoolRetirementEpochInfo x
Generic, Int -> PoolRetirementEpochInfo -> ShowS
[PoolRetirementEpochInfo] -> ShowS
PoolRetirementEpochInfo -> String
(Int -> PoolRetirementEpochInfo -> ShowS)
-> (PoolRetirementEpochInfo -> String)
-> ([PoolRetirementEpochInfo] -> ShowS)
-> Show PoolRetirementEpochInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PoolRetirementEpochInfo] -> ShowS
$cshowList :: [PoolRetirementEpochInfo] -> ShowS
show :: PoolRetirementEpochInfo -> String
$cshow :: PoolRetirementEpochInfo -> String
showsPrec :: Int -> PoolRetirementEpochInfo -> ShowS
$cshowsPrec :: Int -> PoolRetirementEpochInfo -> ShowS
Show)

guardJoin
    :: Set PoolId
    -> WalletDelegation
    -> PoolId
    -> Maybe PoolRetirementEpochInfo
    -> Either ErrCannotJoin ()
guardJoin :: Set PoolId
-> WalletDelegation
-> PoolId
-> Maybe PoolRetirementEpochInfo
-> Either ErrCannotJoin ()
guardJoin Set PoolId
knownPools WalletDelegation
delegation PoolId
pid Maybe PoolRetirementEpochInfo
mRetirementEpochInfo = do
    Bool -> Either ErrCannotJoin () -> Either ErrCannotJoin ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PoolId
pid PoolId -> Set PoolId -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set PoolId
knownPools) (Either ErrCannotJoin () -> Either ErrCannotJoin ())
-> Either ErrCannotJoin () -> Either ErrCannotJoin ()
forall a b. (a -> b) -> a -> b
$
        ErrCannotJoin -> Either ErrCannotJoin ()
forall a b. a -> Either a b
Left (PoolId -> ErrCannotJoin
ErrNoSuchPool PoolId
pid)

    Maybe PoolRetirementEpochInfo
-> (PoolRetirementEpochInfo -> Either ErrCannotJoin ())
-> Either ErrCannotJoin ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe PoolRetirementEpochInfo
mRetirementEpochInfo ((PoolRetirementEpochInfo -> Either ErrCannotJoin ())
 -> Either ErrCannotJoin ())
-> (PoolRetirementEpochInfo -> Either ErrCannotJoin ())
-> Either ErrCannotJoin ()
forall a b. (a -> b) -> a -> b
$ \PoolRetirementEpochInfo
info ->
        Bool -> Either ErrCannotJoin () -> Either ErrCannotJoin ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PoolRetirementEpochInfo -> EpochNo
currentEpoch PoolRetirementEpochInfo
info EpochNo -> EpochNo -> Bool
forall a. Ord a => a -> a -> Bool
>= PoolRetirementEpochInfo -> EpochNo
retirementEpoch PoolRetirementEpochInfo
info) (Either ErrCannotJoin () -> Either ErrCannotJoin ())
-> Either ErrCannotJoin () -> Either ErrCannotJoin ()
forall a b. (a -> b) -> a -> b
$
            ErrCannotJoin -> Either ErrCannotJoin ()
forall a b. a -> Either a b
Left (PoolId -> ErrCannotJoin
ErrNoSuchPool PoolId
pid)

    Bool -> Either ErrCannotJoin () -> Either ErrCannotJoin ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (([WalletDelegationNext] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [WalletDelegationNext]
next) Bool -> Bool -> Bool
&& (PoolId -> Bool) -> WalletDelegationStatus -> Bool
forall a. IsDelegatingTo a => (PoolId -> Bool) -> a -> Bool
isDelegatingTo (PoolId -> PoolId -> Bool
forall a. Eq a => a -> a -> Bool
== PoolId
pid) WalletDelegationStatus
active) (Either ErrCannotJoin () -> Either ErrCannotJoin ())
-> Either ErrCannotJoin () -> Either ErrCannotJoin ()
forall a b. (a -> b) -> a -> b
$
        ErrCannotJoin -> Either ErrCannotJoin ()
forall a b. a -> Either a b
Left (PoolId -> ErrCannotJoin
ErrAlreadyDelegating PoolId
pid)

    Bool -> Either ErrCannotJoin () -> Either ErrCannotJoin ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not ([WalletDelegationNext] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [WalletDelegationNext]
next) Bool -> Bool -> Bool
&& (PoolId -> Bool) -> WalletDelegationNext -> Bool
forall a. IsDelegatingTo a => (PoolId -> Bool) -> a -> Bool
isDelegatingTo (PoolId -> PoolId -> Bool
forall a. Eq a => a -> a -> Bool
== PoolId
pid) ([WalletDelegationNext] -> WalletDelegationNext
forall a. [a] -> a
last [WalletDelegationNext]
next)) (Either ErrCannotJoin () -> Either ErrCannotJoin ())
-> Either ErrCannotJoin () -> Either ErrCannotJoin ()
forall a b. (a -> b) -> a -> b
$
        ErrCannotJoin -> Either ErrCannotJoin ()
forall a b. a -> Either a b
Left (PoolId -> ErrCannotJoin
ErrAlreadyDelegating PoolId
pid)
  where
    WalletDelegation {WalletDelegationStatus
$sel:active:WalletDelegation :: WalletDelegation -> WalletDelegationStatus
active :: WalletDelegationStatus
active, [WalletDelegationNext]
$sel:next:WalletDelegation :: WalletDelegation -> [WalletDelegationNext]
next :: [WalletDelegationNext]
next} = WalletDelegation
delegation

guardQuit
    :: WalletDelegation
    -> Withdrawal
    -> Coin
    -> Either ErrCannotQuit ()
guardQuit :: WalletDelegation -> Withdrawal -> Coin -> Either ErrCannotQuit ()
guardQuit WalletDelegation{WalletDelegationStatus
active :: WalletDelegationStatus
$sel:active:WalletDelegation :: WalletDelegation -> WalletDelegationStatus
active,[WalletDelegationNext]
next :: [WalletDelegationNext]
$sel:next:WalletDelegation :: WalletDelegation -> [WalletDelegationNext]
next} Withdrawal
wdrl Coin
rewards = do
    let last_ :: WalletDelegationStatus
last_ = WalletDelegationStatus
-> (WalletDelegationNext -> WalletDelegationStatus)
-> Maybe WalletDelegationNext
-> WalletDelegationStatus
forall b a. b -> (a -> b) -> Maybe a -> b
maybe WalletDelegationStatus
active (((WalletDelegationStatus
  -> Const WalletDelegationStatus WalletDelegationStatus)
 -> WalletDelegationNext
 -> Const WalletDelegationStatus WalletDelegationNext)
-> WalletDelegationNext -> WalletDelegationStatus
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "status"
  ((WalletDelegationStatus
    -> Const WalletDelegationStatus WalletDelegationStatus)
   -> WalletDelegationNext
   -> Const WalletDelegationStatus WalletDelegationNext)
(WalletDelegationStatus
 -> Const WalletDelegationStatus WalletDelegationStatus)
-> WalletDelegationNext
-> Const WalletDelegationStatus WalletDelegationNext
#status) (Maybe WalletDelegationNext -> WalletDelegationStatus)
-> Maybe WalletDelegationNext -> WalletDelegationStatus
forall a b. (a -> b) -> a -> b
$ [WalletDelegationNext] -> Maybe WalletDelegationNext
forall a. [a] -> Maybe a
lastMay [WalletDelegationNext]
next

    Bool -> Either ErrCannotQuit () -> Either ErrCannotQuit ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((PoolId -> Bool) -> WalletDelegationStatus -> Bool
forall a. IsDelegatingTo a => (PoolId -> Bool) -> a -> Bool
isDelegatingTo PoolId -> Bool
forall b. b -> Bool
anyone WalletDelegationStatus
last_) (Either ErrCannotQuit () -> Either ErrCannotQuit ())
-> Either ErrCannotQuit () -> Either ErrCannotQuit ()
forall a b. (a -> b) -> a -> b
$
        ErrCannotQuit -> Either ErrCannotQuit ()
forall a b. a -> Either a b
Left ErrCannotQuit
ErrNotDelegatingOrAboutTo

    case Withdrawal
wdrl of
        WithdrawalSelf {} -> () -> Either ErrCannotQuit ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Withdrawal
_
            | Coin
rewards Coin -> Coin -> Bool
forall a. Eq a => a -> a -> Bool
== Natural -> Coin
Coin Natural
0  -> () -> Either ErrCannotQuit ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            | Bool
otherwise          -> ErrCannotQuit -> Either ErrCannotQuit ()
forall a b. a -> Either a b
Left (ErrCannotQuit -> Either ErrCannotQuit ())
-> ErrCannotQuit -> Either ErrCannotQuit ()
forall a b. (a -> b) -> a -> b
$ Coin -> ErrCannotQuit
ErrNonNullRewards Coin
rewards
  where
    anyone :: b -> Bool
anyone = Bool -> b -> Bool
forall a b. a -> b -> a
const Bool
True

{-------------------------------------------------------------------------------
                                    Logging
-------------------------------------------------------------------------------}

-- | Log messages for actions running within a wallet worker context.
data WalletWorkerLog
    = MsgWallet WalletLog
    | MsgWalletFollow WalletFollowLog
    | MsgChainFollow ChainFollowLog
    deriving (Int -> WalletWorkerLog -> ShowS
[WalletWorkerLog] -> ShowS
WalletWorkerLog -> String
(Int -> WalletWorkerLog -> ShowS)
-> (WalletWorkerLog -> String)
-> ([WalletWorkerLog] -> ShowS)
-> Show WalletWorkerLog
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WalletWorkerLog] -> ShowS
$cshowList :: [WalletWorkerLog] -> ShowS
show :: WalletWorkerLog -> String
$cshow :: WalletWorkerLog -> String
showsPrec :: Int -> WalletWorkerLog -> ShowS
$cshowsPrec :: Int -> WalletWorkerLog -> ShowS
Show, WalletWorkerLog -> WalletWorkerLog -> Bool
(WalletWorkerLog -> WalletWorkerLog -> Bool)
-> (WalletWorkerLog -> WalletWorkerLog -> Bool)
-> Eq WalletWorkerLog
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WalletWorkerLog -> WalletWorkerLog -> Bool
$c/= :: WalletWorkerLog -> WalletWorkerLog -> Bool
== :: WalletWorkerLog -> WalletWorkerLog -> Bool
$c== :: WalletWorkerLog -> WalletWorkerLog -> Bool
Eq)

instance ToText WalletWorkerLog where
    toText :: WalletWorkerLog -> Text
toText = \case
        MsgWallet WalletLog
msg -> WalletLog -> Text
forall a. ToText a => a -> Text
toText WalletLog
msg
        MsgWalletFollow WalletFollowLog
msg -> WalletFollowLog -> Text
forall a. ToText a => a -> Text
toText WalletFollowLog
msg
        MsgChainFollow ChainFollowLog
msg -> ChainFollowLog -> Text
forall a. ToText a => a -> Text
toText ChainFollowLog
msg

instance HasPrivacyAnnotation WalletWorkerLog

instance HasSeverityAnnotation WalletWorkerLog where
    getSeverityAnnotation :: WalletWorkerLog -> Severity
getSeverityAnnotation = \case
        MsgWallet WalletLog
msg -> WalletLog -> Severity
forall a. HasSeverityAnnotation a => a -> Severity
getSeverityAnnotation WalletLog
msg
        MsgWalletFollow WalletFollowLog
msg -> WalletFollowLog -> Severity
forall a. HasSeverityAnnotation a => a -> Severity
getSeverityAnnotation WalletFollowLog
msg
        MsgChainFollow ChainFollowLog
msg -> ChainFollowLog -> Severity
forall a. HasSeverityAnnotation a => a -> Severity
getSeverityAnnotation ChainFollowLog
msg

-- | Log messages arising from the restore and follow process.
data WalletFollowLog
    = MsgDiscoveredDelegationCert SlotNo DelegationCertificate
    | MsgCheckpoint BlockHeader
    | MsgDiscoveredTxs [(Tx, TxMeta)]
    | MsgDiscoveredTxsContent [(Tx, TxMeta)]
    deriving (Int -> WalletFollowLog -> ShowS
[WalletFollowLog] -> ShowS
WalletFollowLog -> String
(Int -> WalletFollowLog -> ShowS)
-> (WalletFollowLog -> String)
-> ([WalletFollowLog] -> ShowS)
-> Show WalletFollowLog
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WalletFollowLog] -> ShowS
$cshowList :: [WalletFollowLog] -> ShowS
show :: WalletFollowLog -> String
$cshow :: WalletFollowLog -> String
showsPrec :: Int -> WalletFollowLog -> ShowS
$cshowsPrec :: Int -> WalletFollowLog -> ShowS
Show, WalletFollowLog -> WalletFollowLog -> Bool
(WalletFollowLog -> WalletFollowLog -> Bool)
-> (WalletFollowLog -> WalletFollowLog -> Bool)
-> Eq WalletFollowLog
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WalletFollowLog -> WalletFollowLog -> Bool
$c/= :: WalletFollowLog -> WalletFollowLog -> Bool
== :: WalletFollowLog -> WalletFollowLog -> Bool
$c== :: WalletFollowLog -> WalletFollowLog -> Bool
Eq)

-- | Helper wrapper type for the sake of logging.
data BuildableInAnyEra tx = forall era.
    ( Eq (tx era)
    , Show (tx era)
    , Buildable (tx era)
    ) => BuildableInAnyEra (Cardano.CardanoEra era) (tx era)

instance Show (BuildableInAnyEra a) where
    show :: BuildableInAnyEra a -> String
show (BuildableInAnyEra CardanoEra era
_ a era
a) = a era -> String
forall a. Show a => a -> String
show a era
a

instance Eq (BuildableInAnyEra a) where
    BuildableInAnyEra CardanoEra era
era1 a era
thing1 == :: BuildableInAnyEra a -> BuildableInAnyEra a -> Bool
== BuildableInAnyEra CardanoEra era
era2 a era
thing2 =
        case CardanoEra era -> CardanoEra era -> Maybe (era :~: era)
forall k (f :: k -> *) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality CardanoEra era
era1 CardanoEra era
era2 of
            Just era :~: era
Refl -> a era
thing1 a era -> a era -> Bool
forall a. Eq a => a -> a -> Bool
== a era
a era
thing2
            Maybe (era :~: era)
Nothing -> Bool
False

instance Buildable (BuildableInAnyEra a) where
    build :: BuildableInAnyEra a -> Builder
build (BuildableInAnyEra CardanoEra era
_ a era
x) = a era -> Builder
forall p. Buildable p => p -> Builder
build a era
x

-- | Log messages from API server actions running in a wallet worker context.
data WalletLog
    = MsgSelectionStart Int [TxOut]
    | MsgSelectionForBalancingStart Int (BuildableInAnyEra PartialTx)
    | MsgSelectionError (SelectionError WalletSelectionContext)
    | MsgSelectionReportSummarized SelectionReportSummarized
    | MsgSelectionReportDetailed SelectionReportDetailed
    | MsgMigrationUTxOBefore UTxOStatistics
    | MsgMigrationUTxOAfter UTxOStatistics
    | MsgRewardBalanceQuery BlockHeader
    | MsgRewardBalanceResult (Either ErrFetchRewards Coin)
    | MsgRewardBalanceNoSuchWallet ErrNoSuchWallet
    | MsgRewardBalanceExited
    | MsgTxSubmit TxSubmitLog
    | MsgIsStakeKeyRegistered Bool
    deriving (Int -> WalletLog -> ShowS
[WalletLog] -> ShowS
WalletLog -> String
(Int -> WalletLog -> ShowS)
-> (WalletLog -> String)
-> ([WalletLog] -> ShowS)
-> Show WalletLog
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WalletLog] -> ShowS
$cshowList :: [WalletLog] -> ShowS
show :: WalletLog -> String
$cshow :: WalletLog -> String
showsPrec :: Int -> WalletLog -> ShowS
$cshowsPrec :: Int -> WalletLog -> ShowS
Show, WalletLog -> WalletLog -> Bool
(WalletLog -> WalletLog -> Bool)
-> (WalletLog -> WalletLog -> Bool) -> Eq WalletLog
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WalletLog -> WalletLog -> Bool
$c/= :: WalletLog -> WalletLog -> Bool
== :: WalletLog -> WalletLog -> Bool
$c== :: WalletLog -> WalletLog -> Bool
Eq)

instance ToText WalletFollowLog where
    toText :: WalletFollowLog -> Text
toText = \case
        MsgDiscoveredDelegationCert SlotNo
slotNo DelegationCertificate
cert -> case DelegationCertificate
cert of
            CertDelegateNone{} -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
                [ Text
"Discovered end of delegation within slot "
                , SlotNo -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty SlotNo
slotNo
                ]
            CertDelegateFull{} -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
                [ Text
"Discovered delegation to pool "
                , Maybe PoolId -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty (DelegationCertificate -> Maybe PoolId
dlgCertPoolId DelegationCertificate
cert)
                , Text
" within slot "
                , SlotNo -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty SlotNo
slotNo
                ]
            CertRegisterKey {} -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
                [ Text
"Discovered stake key registration "
                , Text
" within slot "
                , SlotNo -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty SlotNo
slotNo
                ]
        MsgCheckpoint BlockHeader
checkpointTip ->
            Text
"Creating checkpoint at " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockHeader -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty BlockHeader
checkpointTip
        MsgDiscoveredTxs [(Tx, TxMeta)]
txs ->
            Text
"discovered " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty ([(Tx, TxMeta)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Tx, TxMeta)]
txs) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" new transaction(s)"
        MsgDiscoveredTxsContent [(Tx, TxMeta)]
txs ->
            Text
"transactions: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Builder -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty ([TxMeta] -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
blockListF ((Tx, TxMeta) -> TxMeta
forall a b. (a, b) -> b
snd ((Tx, TxMeta) -> TxMeta) -> [(Tx, TxMeta)] -> [TxMeta]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Tx, TxMeta)]
txs))

instance ToText WalletLog where
    toText :: WalletLog -> Text
toText = \case
        MsgSelectionStart Int
utxoSize [TxOut]
recipients ->
            Builder
"Starting coin selection " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
            Builder
"|utxo| = "Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+|Int
utxoSizeInt -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+Builder
" " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
            Builder
"#recipients = "Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+|[TxOut] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TxOut]
recipientsInt -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+Builder
""
        MsgSelectionForBalancingStart Int
utxoSize BuildableInAnyEra PartialTx
partialTx ->
            Builder
"Starting coin selection for balancing " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
            Builder
"|utxo| = "Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+|Int
utxoSizeInt -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+Builder
" " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
            Builder
"partialTx = "Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+|BuildableInAnyEra PartialTx
partialTxBuildableInAnyEra PartialTx -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+Builder
""
        MsgSelectionError SelectionError WalletSelectionContext
e ->
            Builder
"Failed to select assets:\n"Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+|| SelectionError WalletSelectionContext
e SelectionError WalletSelectionContext -> Builder -> Builder
forall a b. (Show a, FromBuilder b) => a -> Builder -> b
||+Builder
""
        MsgSelectionReportSummarized SelectionReportSummarized
s ->
            Builder
"Selection report (summarized):\n"Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| SelectionReportSummarized
s SelectionReportSummarized -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+Builder
""
        MsgSelectionReportDetailed SelectionReportDetailed
s ->
            Builder
"Selection report (detailed):\n"Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| SelectionReportDetailed
s SelectionReportDetailed -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+Builder
""
        MsgMigrationUTxOBefore UTxOStatistics
summary ->
            Text
"About to migrate the following distribution: \n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> UTxOStatistics -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty UTxOStatistics
summary
        MsgMigrationUTxOAfter UTxOStatistics
summary ->
            Text
"Expected distribution after complete migration: \n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> UTxOStatistics -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty UTxOStatistics
summary
        MsgRewardBalanceQuery BlockHeader
bh ->
            Text
"Updating the reward balance for block " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockHeader -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty BlockHeader
bh
        MsgRewardBalanceResult (Right Coin
amt) ->
            Text
"The reward balance is " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Coin -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty Coin
amt
        MsgRewardBalanceNoSuchWallet ErrNoSuchWallet
err ->
            Text
"Trying to store a balance for a wallet that doesn't exist (yet?): " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
            String -> Text
T.pack (ErrNoSuchWallet -> String
forall a. Show a => a -> String
show ErrNoSuchWallet
err)
        MsgRewardBalanceResult (Left ErrFetchRewards
err) ->
            Text
"Problem fetching reward balance. Will try again on next chain update. " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
            String -> Text
T.pack (ErrFetchRewards -> String
forall a. Show a => a -> String
show ErrFetchRewards
err)
        WalletLog
MsgRewardBalanceExited ->
            Text
"Reward balance worker has exited."
        MsgTxSubmit TxSubmitLog
msg ->
            TxSubmitLog -> Text
forall a. ToText a => a -> Text
toText TxSubmitLog
msg
        MsgIsStakeKeyRegistered Bool
True ->
            Text
"Wallet stake key is registered. Will not register it again."
        MsgIsStakeKeyRegistered Bool
False ->
            Text
"Wallet stake key is not registered. Will register..."

instance HasPrivacyAnnotation WalletFollowLog
instance HasSeverityAnnotation WalletFollowLog where
    getSeverityAnnotation :: WalletFollowLog -> Severity
getSeverityAnnotation = \case
        MsgDiscoveredDelegationCert SlotNo
_ DelegationCertificate
_ -> Severity
Info
        MsgCheckpoint BlockHeader
_ -> Severity
Debug
        MsgDiscoveredTxs [] -> Severity
Debug
        MsgDiscoveredTxs [(Tx, TxMeta)]
_ -> Severity
Info
        MsgDiscoveredTxsContent [(Tx, TxMeta)]
_ -> Severity
Debug

instance HasPrivacyAnnotation WalletLog
instance HasSeverityAnnotation WalletLog where
    getSeverityAnnotation :: WalletLog -> Severity
getSeverityAnnotation = \case
        MsgSelectionStart{} -> Severity
Debug
        MsgSelectionForBalancingStart{} -> Severity
Debug
        MsgSelectionError{} -> Severity
Debug
        MsgSelectionReportSummarized{} -> Severity
Info
        MsgSelectionReportDetailed{} -> Severity
Debug
        MsgMigrationUTxOBefore UTxOStatistics
_ -> Severity
Info
        MsgMigrationUTxOAfter UTxOStatistics
_ -> Severity
Info
        MsgRewardBalanceQuery BlockHeader
_ -> Severity
Debug
        MsgRewardBalanceResult (Right Coin
_) -> Severity
Debug
        MsgRewardBalanceResult (Left ErrFetchRewards
_) -> Severity
Notice
        MsgRewardBalanceNoSuchWallet{} -> Severity
Warning
        WalletLog
MsgRewardBalanceExited -> Severity
Notice
        MsgTxSubmit TxSubmitLog
msg -> TxSubmitLog -> Severity
forall a. HasSeverityAnnotation a => a -> Severity
getSeverityAnnotation TxSubmitLog
msg
        MsgIsStakeKeyRegistered Bool
_ -> Severity
Info

data TxSubmitLog
    = MsgSubmitTx Tx TxMeta SealedTx (BracketLog' (Either ErrSubmitTx ()))
    | MsgSubmitExternalTx (Hash "Tx") (BracketLog' (Either ErrPostTx Tx))
    | MsgRetryPostTx (Hash "Tx") (BracketLog' (Either ErrPostTx ()))
    | MsgProcessPendingPool BracketLog
    deriving (Int -> TxSubmitLog -> ShowS
[TxSubmitLog] -> ShowS
TxSubmitLog -> String
(Int -> TxSubmitLog -> ShowS)
-> (TxSubmitLog -> String)
-> ([TxSubmitLog] -> ShowS)
-> Show TxSubmitLog
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TxSubmitLog] -> ShowS
$cshowList :: [TxSubmitLog] -> ShowS
show :: TxSubmitLog -> String
$cshow :: TxSubmitLog -> String
showsPrec :: Int -> TxSubmitLog -> ShowS
$cshowsPrec :: Int -> TxSubmitLog -> ShowS
Show, TxSubmitLog -> TxSubmitLog -> Bool
(TxSubmitLog -> TxSubmitLog -> Bool)
-> (TxSubmitLog -> TxSubmitLog -> Bool) -> Eq TxSubmitLog
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TxSubmitLog -> TxSubmitLog -> Bool
$c/= :: TxSubmitLog -> TxSubmitLog -> Bool
== :: TxSubmitLog -> TxSubmitLog -> Bool
$c== :: TxSubmitLog -> TxSubmitLog -> Bool
Eq)

instance ToText TxSubmitLog

instance Buildable TxSubmitLog where
    build :: TxSubmitLog -> Builder
build = \case
        MsgSubmitTx Tx
tx TxMeta
meta SealedTx
sealed BracketLog' (Either ErrSubmitTx ())
msg -> case BracketLog' (Either ErrSubmitTx ())
msg of
            BracketLog' (Either ErrSubmitTx ())
BracketStart -> [Builder] -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
unlinesF
                [ Builder
"Submitting transaction "Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+|Tx
tx Tx
-> ((Hash "Tx" -> Const (Hash "Tx") (Hash "Tx"))
    -> Tx -> Const (Hash "Tx") Tx)
-> Hash "Tx"
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "txId"
  ((Hash "Tx" -> Const (Hash "Tx") (Hash "Tx"))
   -> Tx -> Const (Hash "Tx") Tx)
(Hash "Tx" -> Const (Hash "Tx") (Hash "Tx"))
-> Tx -> Const (Hash "Tx") Tx
#txIdHash "Tx" -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+Builder
" to local node"
                , [(Text, Builder)] -> Builder
forall t k v.
(IsList t, Item t ~ (k, v), Buildable k, Buildable v) =>
t -> Builder
blockMapF
                    [ (Text
"Tx" :: Text, Tx -> Builder
forall p. Buildable p => p -> Builder
build Tx
tx)
                    , (Text
"SealedTx", SealedTx -> Builder
forall p. Buildable p => p -> Builder
build SealedTx
sealed)
                    , (Text
"TxMeta", TxMeta -> Builder
forall p. Buildable p => p -> Builder
build TxMeta
meta) ]
                ]
            BracketFinish Either ErrSubmitTx ()
res ->
                Builder
"Transaction "Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+|Tx
tx Tx
-> ((Hash "Tx" -> Const (Hash "Tx") (Hash "Tx"))
    -> Tx -> Const (Hash "Tx") Tx)
-> Hash "Tx"
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "txId"
  ((Hash "Tx" -> Const (Hash "Tx") (Hash "Tx"))
   -> Tx -> Const (Hash "Tx") Tx)
(Hash "Tx" -> Const (Hash "Tx") (Hash "Tx"))
-> Tx -> Const (Hash "Tx") Tx
#txIdHash "Tx" -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+Builder
" "Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+|case Either ErrSubmitTx ()
res of
                    Right ()
_ -> Builder
"accepted by local node"
                    Left ErrSubmitTx
err -> Builder
"failed: "Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+||ErrSubmitTx
errErrSubmitTx -> Builder -> Builder
forall a b. (Show a, FromBuilder b) => a -> Builder -> b
||+Builder
""
            BracketLog' (Either ErrSubmitTx ())
_ -> Text
-> [(Text, Hash "Tx")]
-> BracketLog' (Either ErrSubmitTx ())
-> Builder
forall e t v r.
(Show e, IsList t, Item t ~ (Text, v), Buildable v, Buildable r) =>
Text -> t -> BracketLog' (Either e r) -> Builder
formatResultMsg Text
"submitTx" [(Text
"txid", Tx
tx Tx
-> ((Hash "Tx" -> Const (Hash "Tx") (Hash "Tx"))
    -> Tx -> Const (Hash "Tx") Tx)
-> Hash "Tx"
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "txId"
  ((Hash "Tx" -> Const (Hash "Tx") (Hash "Tx"))
   -> Tx -> Const (Hash "Tx") Tx)
(Hash "Tx" -> Const (Hash "Tx") (Hash "Tx"))
-> Tx -> Const (Hash "Tx") Tx
#txId)] BracketLog' (Either ErrSubmitTx ())
msg

        MsgSubmitExternalTx Hash "Tx"
txid BracketLog' (Either ErrPostTx Tx)
msg -> case BracketLog' (Either ErrPostTx Tx)
msg of
            BracketLog' (Either ErrPostTx Tx)
BracketStart -> Builder
"Submitting external transaction "Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+|Hash "Tx"
txidHash "Tx" -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+
                Builder
" to local node..."
            BracketFinish Either ErrPostTx Tx
res ->
                Builder
"Transaction "Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+|Hash "Tx"
txidHash "Tx" -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+Builder
" "Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+|case Either ErrPostTx Tx
res of
                    Right Tx
tx -> [Builder] -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
unlinesF
                        [ Builder
"accepted by local node"
                        , Builder -> Builder -> Builder
nameF Builder
"tx" (Tx -> Builder
forall p. Buildable p => p -> Builder
build Tx
tx)
                        ]
                    Left ErrPostTx
err -> Builder
"failed: "Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+|ErrPostTx -> Text
forall a. ToText a => a -> Text
toText ErrPostTx
errText -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+Builder
""
            BracketLog' (Either ErrPostTx Tx)
_ -> Text
-> [(Text, Hash "Tx")]
-> BracketLog' (Either ErrPostTx Tx)
-> Builder
forall e t v r.
(Show e, IsList t, Item t ~ (Text, v), Buildable v, Buildable r) =>
Text -> t -> BracketLog' (Either e r) -> Builder
formatResultMsg Text
"submitExternalTx" [(Text
"txid", Hash "Tx"
txid)] BracketLog' (Either ErrPostTx Tx)
msg

        MsgRetryPostTx Hash "Tx"
txid BracketLog' (Either ErrPostTx ())
msg -> case BracketLog' (Either ErrPostTx ())
msg of
            BracketLog' (Either ErrPostTx ())
BracketStart -> Builder
"Retrying submission of transaction "Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+|Hash "Tx"
txidHash "Tx" -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+
                Builder
" to local node..."
            BracketFinish Either ErrPostTx ()
res ->
                Builder
"Transaction "Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+|Hash "Tx"
txidHash "Tx" -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+Builder
" resubmitted to local node and " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
                case Either ErrPostTx ()
res of
                    Right ()
_ -> Builder
"accepted again"
                    Left ErrPostTx
_ -> Builder
"not accepted (this is expected)"
            BracketLog' (Either ErrPostTx ())
_ -> Text
-> [(Text, Hash "Tx")]
-> BracketLog' (Either ErrPostTx ())
-> Builder
forall e t v r.
(Show e, IsList t, Item t ~ (Text, v), Buildable v, Buildable r) =>
Text -> t -> BracketLog' (Either e r) -> Builder
formatResultMsg Text
"runLocalTxSubmissionPool(postTx)"
                [(Text
"txid", Hash "Tx"
txid)] BracketLog' (Either ErrPostTx ())
msg

        MsgProcessPendingPool BracketLog
msg ->
            Builder
"Processing the pending local tx submission pool: "Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+|BracketLog
msgBracketLog -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+Builder
""

instance HasPrivacyAnnotation TxSubmitLog
instance HasSeverityAnnotation TxSubmitLog where
    getSeverityAnnotation :: TxSubmitLog -> Severity
getSeverityAnnotation = \case
        MsgSubmitTx Tx
_ TxMeta
_ SealedTx
_ BracketLog' (Either ErrSubmitTx ())
b -> Severity -> BracketLog' (Either ErrSubmitTx ()) -> Severity
forall e r. Severity -> BracketLog' (Either e r) -> Severity
resultSeverity Severity
Info BracketLog' (Either ErrSubmitTx ())
b
        MsgSubmitExternalTx Hash "Tx"
_ BracketLog' (Either ErrPostTx Tx)
b -> Severity -> BracketLog' (Either ErrPostTx Tx) -> Severity
forall e r. Severity -> BracketLog' (Either e r) -> Severity
resultSeverity Severity
Info BracketLog' (Either ErrPostTx Tx)
b
        MsgRetryPostTx Hash "Tx"
_ BracketLog' (Either ErrPostTx ())
b -> case BracketLog' (Either ErrPostTx ())
b of
            BracketFinish (Right ()
_) -> Severity
Info
            BracketException LoggedException SomeException
_ -> Severity
Error
            BracketLog' (Either ErrPostTx ())
_ -> Severity
Debug
        MsgProcessPendingPool BracketLog
msg -> BracketLog -> Severity
forall a. HasSeverityAnnotation a => a -> Severity
getSeverityAnnotation BracketLog
msg

-- | Convert a 'Cardano.Value' into a positive and negative component. Useful
-- to convert the potentially negative balance of a partial tx into
-- TokenBundles.
posAndNegFromCardanoValue
    :: Cardano.Value
    -> (TokenBundle.TokenBundle, TokenBundle.TokenBundle)
posAndNegFromCardanoValue :: Value -> (TokenBundle, TokenBundle)
posAndNegFromCardanoValue = ((AssetId, Quantity) -> (TokenBundle, TokenBundle))
-> [(AssetId, Quantity)] -> (TokenBundle, TokenBundle)
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (AssetId, Quantity) -> (TokenBundle, TokenBundle)
go ([(AssetId, Quantity)] -> (TokenBundle, TokenBundle))
-> (Value -> [(AssetId, Quantity)])
-> Value
-> (TokenBundle, TokenBundle)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> [(AssetId, Quantity)]
Cardano.valueToList
  where
    go :: (Cardano.AssetId, Cardano.Quantity)
       -> (TokenBundle.TokenBundle, TokenBundle.TokenBundle)
    go :: (AssetId, Quantity) -> (TokenBundle, TokenBundle)
go (AssetId
Cardano.AdaAssetId, Quantity
q) = Quantity -> (Natural -> TokenBundle) -> (TokenBundle, TokenBundle)
partition Quantity
q ((Natural -> TokenBundle) -> (TokenBundle, TokenBundle))
-> (Natural -> TokenBundle) -> (TokenBundle, TokenBundle)
forall a b. (a -> b) -> a -> b
$
        Coin -> TokenBundle
TokenBundle.fromCoin (Coin -> TokenBundle)
-> (Natural -> Coin) -> Natural -> TokenBundle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> Coin
Coin.fromNatural
    go ((Cardano.AssetId PolicyId
policy AssetName
name), Quantity
q) = Quantity -> (Natural -> TokenBundle) -> (TokenBundle, TokenBundle)
partition Quantity
q ((Natural -> TokenBundle) -> (TokenBundle, TokenBundle))
-> (Natural -> TokenBundle) -> (TokenBundle, TokenBundle)
forall a b. (a -> b) -> a -> b
$ \Natural
n ->
        Coin -> [(AssetId, TokenQuantity)] -> TokenBundle
TokenBundle.fromFlatList (Natural -> Coin
Coin Natural
0)
            [ ( TokenPolicyId -> TokenName -> AssetId
TokenBundle.AssetId (PolicyId -> TokenPolicyId
mkPolicyId PolicyId
policy) (AssetName -> TokenName
mkTokenName AssetName
name)
              , Natural -> TokenQuantity
TokenQuantity Natural
n
              )
            ]

    -- | Convert a 'Cardano.Quantity' to a 'TokenBundle' using the supplied
    -- function. The result is stored in 'fst' for positive quantities, and
    -- 'snd' for negative quantities.
    partition
        :: Cardano.Quantity
        -> (Natural -> TokenBundle.TokenBundle)
        -> (TokenBundle.TokenBundle, TokenBundle.TokenBundle)
    partition :: Quantity -> (Natural -> TokenBundle) -> (TokenBundle, TokenBundle)
partition (Cardano.Quantity BlockHeight
i) Natural -> TokenBundle
f
        | Just Natural
n <- BlockHeight -> Maybe Natural
maybeIntegerToNatural      BlockHeight
i  = (Natural -> TokenBundle
f Natural
n, TokenBundle
forall a. Monoid a => a
mempty)
        | Just Natural
n <- BlockHeight -> Maybe Natural
maybeIntegerToNatural (BlockHeight -> BlockHeight
forall a. Num a => a -> a
abs BlockHeight
i) = (TokenBundle
forall a. Monoid a => a
mempty, Natural -> TokenBundle
f Natural
n)
        | Bool
otherwise = (TokenBundle
forall a. Monoid a => a
mempty, TokenBundle
forall a. Monoid a => a
mempty)

    maybeIntegerToNatural :: BlockHeight -> Maybe Natural
maybeIntegerToNatural = (Integral BlockHeight, Integral Natural, Bits BlockHeight,
 Bits Natural) =>
BlockHeight -> Maybe Natural
forall a b.
(Integral a, Integral b, Bits a, Bits b) =>
a -> Maybe b
intCastMaybe @Integer @Natural

    mkPolicyId :: PolicyId -> TokenPolicyId
mkPolicyId = Hash "TokenPolicy" -> TokenPolicyId
UnsafeTokenPolicyId (Hash "TokenPolicy" -> TokenPolicyId)
-> (PolicyId -> Hash "TokenPolicy") -> PolicyId -> TokenPolicyId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Hash "TokenPolicy"
forall (tag :: Symbol). ByteString -> Hash tag
Hash (ByteString -> Hash "TokenPolicy")
-> (PolicyId -> ByteString) -> PolicyId -> Hash "TokenPolicy"
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PolicyId -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
Cardano.serialiseToRawBytes
    mkTokenName :: AssetName -> TokenName
mkTokenName = ByteString -> TokenName
UnsafeTokenName (ByteString -> TokenName)
-> (AssetName -> ByteString) -> AssetName -> TokenName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AssetName -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
Cardano.serialiseToRawBytes