{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}

-- |
-- Copyright: © 2018-2020 IOHK
-- License: Apache-2.0
--
-- Dummy implementation of the database-layer, using 'MVar'. This may be good
-- for testing to compare with an implementation on a real data store, or to use
-- when compiling the wallet for targets which don't have SQLite.

module Cardano.Wallet.DB.Pure.Layer
    ( newDBLayer
    ) where

import Prelude

import Cardano.Address.Derivation
    ( XPrv )
import Cardano.Wallet.DB
    ( DBLayer (..)
    , ErrNoSuchTransaction (..)
    , ErrPutLocalTxSubmission (..)
    , ErrRemoveTx (..)
    , ErrWalletAlreadyExists (..)
    )
import Cardano.Wallet.DB.Pure.Implementation
    ( Database
    , Err (..)
    , ModelOp
    , emptyDatabase
    , mCheckWallet
    , mInitializeWallet
    , mIsStakeKeyRegistered
    , mListCheckpoints
    , mListWallets
    , mPutCheckpoint
    , mPutDelegationCertificate
    , mPutDelegationRewardBalance
    , mPutLocalTxSubmission
    , mPutPrivateKey
    , mPutTxHistory
    , mPutWalletMeta
    , mReadCheckpoint
    , mReadDelegationRewardBalance
    , mReadGenesisParameters
    , mReadLocalTxSubmissionPending
    , mReadPrivateKey
    , mReadTxHistory
    , mReadWalletMeta
    , mRemovePendingOrExpiredTx
    , mRemoveWallet
    , mRollbackTo
    , mUpdatePendingTxForExpiry
    )
import Cardano.Wallet.DB.WalletState
    ( ErrNoSuchWallet (..) )
import Cardano.Wallet.Primitive.AddressDerivation
    ( Depth (..) )
import Cardano.Wallet.Primitive.Passphrase
    ( PassphraseHash )
import Cardano.Wallet.Primitive.Slotting
    ( TimeInterpreter )
import Cardano.Wallet.Primitive.Types
    ( SortOrder (..), WalletId, wholeRange )
import Cardano.Wallet.Primitive.Types.Tx
    ( TransactionInfo (..) )
import Control.Monad.IO.Unlift
    ( MonadUnliftIO (..) )
import Control.Monad.Trans.Except
    ( ExceptT (..) )
import Data.Functor.Identity
    ( Identity (..) )
import UnliftIO.Exception
    ( Exception, throwIO )
import UnliftIO.MVar
    ( MVar, modifyMVar, newMVar, withMVar )

-- | Instantiate a new in-memory "database" layer that simply stores data in
-- a local MVar. Data vanishes if the software is shut down.
newDBLayer
    :: forall m s k.
       ( MonadUnliftIO m
       , MonadFail m )
    => TimeInterpreter Identity
    -> m (DBLayer m s k)
newDBLayer :: TimeInterpreter Identity -> m (DBLayer m s k)
newDBLayer TimeInterpreter Identity
timeInterpreter = do
    MVar ()
lock <- () -> m (MVar ())
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar ()
    MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
db <- Database WalletId s (k 'RootK XPrv, PassphraseHash)
-> m (MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash)))
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar (forall wid s xprv. Ord wid => Database wid s xprv
forall s (k :: Depth -> * -> *).
Database WalletId s (k 'RootK XPrv, PassphraseHash)
emptyDatabase :: Database WalletId s (k 'RootK XPrv, PassphraseHash))
    DBLayer m s k -> m (DBLayer m s k)
forall (m :: * -> *) a. Monad m => a -> m a
return (DBLayer m s k -> m (DBLayer m s k))
-> DBLayer m s k -> m (DBLayer m s k)
forall a b. (a -> b) -> a -> b
$ DBLayer :: forall (m :: * -> *) s (k :: Depth -> * -> *) (stm :: * -> *).
(MonadIO stm, MonadFail stm) =>
(WalletId
 -> Wallet s
 -> WalletMetadata
 -> [(Tx, TxMeta)]
 -> GenesisParameters
 -> ExceptT ErrWalletAlreadyExists stm ())
-> (WalletId -> ExceptT ErrNoSuchWallet stm ())
-> stm [WalletId]
-> DBVar stm (DeltaMap WalletId (DeltaWalletState s))
-> (WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ())
-> (WalletId -> stm (Maybe (Wallet s)))
-> (WalletId -> stm [ChainPoint])
-> (WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ())
-> (WalletId -> stm (Maybe WalletMetadata))
-> (WalletId -> ExceptT ErrNoSuchWallet stm Bool)
-> (WalletId
    -> DelegationCertificate
    -> SlotNo
    -> ExceptT ErrNoSuchWallet stm ())
-> (WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ())
-> (WalletId -> stm Coin)
-> (WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ())
-> (WalletId
    -> Maybe Coin
    -> SortOrder
    -> Range SlotNo
    -> Maybe TxStatus
    -> stm [TransactionInfo])
-> (WalletId
    -> Hash "Tx"
    -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo))
-> (WalletId
    -> Hash "Tx"
    -> SealedTx
    -> SlotNo
    -> ExceptT ErrPutLocalTxSubmission stm ())
-> (WalletId -> stm [LocalTxSubmissionStatus SealedTx])
-> (WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ())
-> (WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ())
-> (WalletId
    -> (k 'RootK XPrv, PassphraseHash)
    -> ExceptT ErrNoSuchWallet stm ())
-> (WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash)))
-> (WalletId -> stm (Maybe GenesisParameters))
-> (WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint)
-> (WalletId
    -> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ())
-> (forall a. stm a -> m a)
-> DBLayer m s k
DBLayer

        {-----------------------------------------------------------------------
                                      Wallets
        -----------------------------------------------------------------------}

        { initializeWallet :: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists m ()
initializeWallet = \WalletId
pk Wallet s
cp WalletMetadata
meta [(Tx, TxMeta)]
txs GenesisParameters
gp -> m (Either ErrWalletAlreadyExists ())
-> ExceptT ErrWalletAlreadyExists m ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either ErrWalletAlreadyExists ())
 -> ExceptT ErrWalletAlreadyExists m ())
-> m (Either ErrWalletAlreadyExists ())
-> ExceptT ErrWalletAlreadyExists m ()
forall a b. (a -> b) -> a -> b
$
                (Err WalletId -> Maybe ErrWalletAlreadyExists)
-> MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
-> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ()
-> m (Either ErrWalletAlreadyExists ())
forall (m :: * -> *) err s xprv a.
MonadUnliftIO m =>
(Err WalletId -> Maybe err)
-> MVar (Database WalletId s xprv)
-> ModelOp WalletId s xprv a
-> m (Either err a)
alterDB Err WalletId -> Maybe ErrWalletAlreadyExists
errWalletAlreadyExists MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
db (ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ()
 -> m (Either ErrWalletAlreadyExists ()))
-> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ()
-> m (Either ErrWalletAlreadyExists ())
forall a b. (a -> b) -> a -> b
$
                WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ()
forall wid s xprv.
Ord wid =>
wid
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ModelOp wid s xprv ()
mInitializeWallet WalletId
pk Wallet s
cp WalletMetadata
meta [(Tx, TxMeta)]
txs GenesisParameters
gp

        , removeWallet :: WalletId -> ExceptT ErrNoSuchWallet m ()
removeWallet = m (Either ErrNoSuchWallet ()) -> ExceptT ErrNoSuchWallet m ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either ErrNoSuchWallet ()) -> ExceptT ErrNoSuchWallet m ())
-> (WalletId -> m (Either ErrNoSuchWallet ()))
-> WalletId
-> ExceptT ErrNoSuchWallet m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Err WalletId -> Maybe ErrNoSuchWallet)
-> MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
-> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ()
-> m (Either ErrNoSuchWallet ())
forall (m :: * -> *) err s xprv a.
MonadUnliftIO m =>
(Err WalletId -> Maybe err)
-> MVar (Database WalletId s xprv)
-> ModelOp WalletId s xprv a
-> m (Either err a)
alterDB Err WalletId -> Maybe ErrNoSuchWallet
errNoSuchWallet MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
db (ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ()
 -> m (Either ErrNoSuchWallet ()))
-> (WalletId
    -> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ())
-> WalletId
-> m (Either ErrNoSuchWallet ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WalletId -> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ()
forall wid s xprv. Ord wid => wid -> ModelOp wid s xprv ()
mRemoveWallet

        , listWallets :: m [WalletId]
listWallets = MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
-> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) [WalletId]
-> m [WalletId]
forall (m :: * -> *) s xprv a.
MonadUnliftIO m =>
MVar (Database WalletId s xprv) -> ModelOp WalletId s xprv a -> m a
readDB MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
db ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) [WalletId]
forall wid s xprv. Ord wid => ModelOp wid s xprv [wid]
mListWallets

        {-----------------------------------------------------------------------
                                    Checkpoints
        -----------------------------------------------------------------------}
        , walletsDB :: DBVar m (DeltaMap WalletId (DeltaWalletState s))
walletsDB = [Char] -> DBVar m (DeltaMap WalletId (DeltaWalletState s))
forall a. HasCallStack => [Char] -> a
error [Char]
"MVar.walletsDB: not implemented"

        , putCheckpoint :: WalletId -> Wallet s -> ExceptT ErrNoSuchWallet m ()
putCheckpoint = \WalletId
pk Wallet s
cp -> m (Either ErrNoSuchWallet ()) -> ExceptT ErrNoSuchWallet m ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either ErrNoSuchWallet ()) -> ExceptT ErrNoSuchWallet m ())
-> m (Either ErrNoSuchWallet ()) -> ExceptT ErrNoSuchWallet m ()
forall a b. (a -> b) -> a -> b
$
            (Err WalletId -> Maybe ErrNoSuchWallet)
-> MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
-> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ()
-> m (Either ErrNoSuchWallet ())
forall (m :: * -> *) err s xprv a.
MonadUnliftIO m =>
(Err WalletId -> Maybe err)
-> MVar (Database WalletId s xprv)
-> ModelOp WalletId s xprv a
-> m (Either err a)
alterDB Err WalletId -> Maybe ErrNoSuchWallet
errNoSuchWallet MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
db (ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ()
 -> m (Either ErrNoSuchWallet ()))
-> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ()
-> m (Either ErrNoSuchWallet ())
forall a b. (a -> b) -> a -> b
$
            WalletId
-> Wallet s
-> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ()
forall wid s xprv.
Ord wid =>
wid -> Wallet s -> ModelOp wid s xprv ()
mPutCheckpoint WalletId
pk Wallet s
cp

        , readCheckpoint :: WalletId -> m (Maybe (Wallet s))
readCheckpoint = MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
-> ModelOp
     WalletId s (k 'RootK XPrv, PassphraseHash) (Maybe (Wallet s))
-> m (Maybe (Wallet s))
forall (m :: * -> *) s xprv a.
MonadUnliftIO m =>
MVar (Database WalletId s xprv) -> ModelOp WalletId s xprv a -> m a
readDB MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
db (ModelOp
   WalletId s (k 'RootK XPrv, PassphraseHash) (Maybe (Wallet s))
 -> m (Maybe (Wallet s)))
-> (WalletId
    -> ModelOp
         WalletId s (k 'RootK XPrv, PassphraseHash) (Maybe (Wallet s)))
-> WalletId
-> m (Maybe (Wallet s))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WalletId
-> ModelOp
     WalletId s (k 'RootK XPrv, PassphraseHash) (Maybe (Wallet s))
forall wid s xprv.
Ord wid =>
wid -> ModelOp wid s xprv (Maybe (Wallet s))
mReadCheckpoint

        , listCheckpoints :: WalletId -> m [ChainPoint]
listCheckpoints = MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
-> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) [ChainPoint]
-> m [ChainPoint]
forall (m :: * -> *) s xprv a.
MonadUnliftIO m =>
MVar (Database WalletId s xprv) -> ModelOp WalletId s xprv a -> m a
readDB MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
db (ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) [ChainPoint]
 -> m [ChainPoint])
-> (WalletId
    -> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) [ChainPoint])
-> WalletId
-> m [ChainPoint]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WalletId
-> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) [ChainPoint]
forall wid s xprv.
Ord wid =>
wid -> ModelOp wid s xprv [ChainPoint]
mListCheckpoints

        , rollbackTo :: WalletId -> Slot -> ExceptT ErrNoSuchWallet m ChainPoint
rollbackTo = \WalletId
pk Slot
pt -> m (Either ErrNoSuchWallet ChainPoint)
-> ExceptT ErrNoSuchWallet m ChainPoint
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either ErrNoSuchWallet ChainPoint)
 -> ExceptT ErrNoSuchWallet m ChainPoint)
-> m (Either ErrNoSuchWallet ChainPoint)
-> ExceptT ErrNoSuchWallet m ChainPoint
forall a b. (a -> b) -> a -> b
$
            (Err WalletId -> Maybe ErrNoSuchWallet)
-> MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
-> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ChainPoint
-> m (Either ErrNoSuchWallet ChainPoint)
forall (m :: * -> *) err s xprv a.
MonadUnliftIO m =>
(Err WalletId -> Maybe err)
-> MVar (Database WalletId s xprv)
-> ModelOp WalletId s xprv a
-> m (Either err a)
alterDB Err WalletId -> Maybe ErrNoSuchWallet
errNoSuchWallet MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
db (ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ChainPoint
 -> m (Either ErrNoSuchWallet ChainPoint))
-> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ChainPoint
-> m (Either ErrNoSuchWallet ChainPoint)
forall a b. (a -> b) -> a -> b
$
            WalletId
-> Slot
-> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ChainPoint
forall wid s xprv.
Ord wid =>
wid -> Slot -> ModelOp wid s xprv ChainPoint
mRollbackTo WalletId
pk Slot
pt

        , prune :: WalletId -> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet m ()
prune = \WalletId
_ Quantity "block" Word32
_ -> [Char] -> ExceptT ErrNoSuchWallet m ()
forall a. HasCallStack => [Char] -> a
error [Char]
"MVar.prune: not implemented"

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

        , putWalletMeta :: WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet m ()
putWalletMeta = \WalletId
pk WalletMetadata
meta -> m (Either ErrNoSuchWallet ()) -> ExceptT ErrNoSuchWallet m ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either ErrNoSuchWallet ()) -> ExceptT ErrNoSuchWallet m ())
-> m (Either ErrNoSuchWallet ()) -> ExceptT ErrNoSuchWallet m ()
forall a b. (a -> b) -> a -> b
$
            (Err WalletId -> Maybe ErrNoSuchWallet)
-> MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
-> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ()
-> m (Either ErrNoSuchWallet ())
forall (m :: * -> *) err s xprv a.
MonadUnliftIO m =>
(Err WalletId -> Maybe err)
-> MVar (Database WalletId s xprv)
-> ModelOp WalletId s xprv a
-> m (Either err a)
alterDB Err WalletId -> Maybe ErrNoSuchWallet
errNoSuchWallet MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
db (ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ()
 -> m (Either ErrNoSuchWallet ()))
-> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ()
-> m (Either ErrNoSuchWallet ())
forall a b. (a -> b) -> a -> b
$
            WalletId
-> WalletMetadata
-> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ()
forall wid s xprv.
Ord wid =>
wid -> WalletMetadata -> ModelOp wid s xprv ()
mPutWalletMeta WalletId
pk WalletMetadata
meta

        , readWalletMeta :: WalletId -> m (Maybe WalletMetadata)
readWalletMeta = MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
-> ModelOp
     WalletId s (k 'RootK XPrv, PassphraseHash) (Maybe WalletMetadata)
-> m (Maybe WalletMetadata)
forall (m :: * -> *) s xprv a.
MonadUnliftIO m =>
MVar (Database WalletId s xprv) -> ModelOp WalletId s xprv a -> m a
readDB MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
db (ModelOp
   WalletId s (k 'RootK XPrv, PassphraseHash) (Maybe WalletMetadata)
 -> m (Maybe WalletMetadata))
-> (WalletId
    -> ModelOp
         WalletId s (k 'RootK XPrv, PassphraseHash) (Maybe WalletMetadata))
-> WalletId
-> m (Maybe WalletMetadata)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeInterpreter Identity
-> WalletId
-> ModelOp
     WalletId s (k 'RootK XPrv, PassphraseHash) (Maybe WalletMetadata)
forall wid s xprv.
Ord wid =>
TimeInterpreter Identity
-> wid -> ModelOp wid s xprv (Maybe WalletMetadata)
mReadWalletMeta TimeInterpreter Identity
timeInterpreter

        , putDelegationCertificate :: WalletId
-> DelegationCertificate -> SlotNo -> ExceptT ErrNoSuchWallet m ()
putDelegationCertificate = \WalletId
pk DelegationCertificate
cert SlotNo
sl -> m (Either ErrNoSuchWallet ()) -> ExceptT ErrNoSuchWallet m ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either ErrNoSuchWallet ()) -> ExceptT ErrNoSuchWallet m ())
-> m (Either ErrNoSuchWallet ()) -> ExceptT ErrNoSuchWallet m ()
forall a b. (a -> b) -> a -> b
$
            (Err WalletId -> Maybe ErrNoSuchWallet)
-> MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
-> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ()
-> m (Either ErrNoSuchWallet ())
forall (m :: * -> *) err s xprv a.
MonadUnliftIO m =>
(Err WalletId -> Maybe err)
-> MVar (Database WalletId s xprv)
-> ModelOp WalletId s xprv a
-> m (Either err a)
alterDB Err WalletId -> Maybe ErrNoSuchWallet
errNoSuchWallet MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
db (ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ()
 -> m (Either ErrNoSuchWallet ()))
-> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ()
-> m (Either ErrNoSuchWallet ())
forall a b. (a -> b) -> a -> b
$
            WalletId
-> DelegationCertificate
-> SlotNo
-> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ()
forall wid s xprv.
Ord wid =>
wid -> DelegationCertificate -> SlotNo -> ModelOp wid s xprv ()
mPutDelegationCertificate WalletId
pk DelegationCertificate
cert SlotNo
sl

        , isStakeKeyRegistered :: WalletId -> ExceptT ErrNoSuchWallet m Bool
isStakeKeyRegistered =
            m (Either ErrNoSuchWallet Bool) -> ExceptT ErrNoSuchWallet m Bool
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either ErrNoSuchWallet Bool) -> ExceptT ErrNoSuchWallet m Bool)
-> (WalletId -> m (Either ErrNoSuchWallet Bool))
-> WalletId
-> ExceptT ErrNoSuchWallet m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Err WalletId -> Maybe ErrNoSuchWallet)
-> MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
-> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) Bool
-> m (Either ErrNoSuchWallet Bool)
forall (m :: * -> *) err s xprv a.
MonadUnliftIO m =>
(Err WalletId -> Maybe err)
-> MVar (Database WalletId s xprv)
-> ModelOp WalletId s xprv a
-> m (Either err a)
alterDB Err WalletId -> Maybe ErrNoSuchWallet
errNoSuchWallet MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
db (ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) Bool
 -> m (Either ErrNoSuchWallet Bool))
-> (WalletId
    -> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) Bool)
-> WalletId
-> m (Either ErrNoSuchWallet Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WalletId -> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) Bool
forall wid s xprv. Ord wid => wid -> ModelOp wid s xprv Bool
mIsStakeKeyRegistered

        {-----------------------------------------------------------------------
                                     Tx History
        -----------------------------------------------------------------------}

        , putTxHistory :: WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet m ()
putTxHistory = \WalletId
pk [(Tx, TxMeta)]
txh -> m (Either ErrNoSuchWallet ()) -> ExceptT ErrNoSuchWallet m ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either ErrNoSuchWallet ()) -> ExceptT ErrNoSuchWallet m ())
-> m (Either ErrNoSuchWallet ()) -> ExceptT ErrNoSuchWallet m ()
forall a b. (a -> b) -> a -> b
$
            (Err WalletId -> Maybe ErrNoSuchWallet)
-> MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
-> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ()
-> m (Either ErrNoSuchWallet ())
forall (m :: * -> *) err s xprv a.
MonadUnliftIO m =>
(Err WalletId -> Maybe err)
-> MVar (Database WalletId s xprv)
-> ModelOp WalletId s xprv a
-> m (Either err a)
alterDB Err WalletId -> Maybe ErrNoSuchWallet
errNoSuchWallet MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
db (ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ()
 -> m (Either ErrNoSuchWallet ()))
-> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ()
-> m (Either ErrNoSuchWallet ())
forall a b. (a -> b) -> a -> b
$
            WalletId
-> [(Tx, TxMeta)]
-> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ()
forall wid s xprv.
Ord wid =>
wid -> [(Tx, TxMeta)] -> ModelOp wid s xprv ()
mPutTxHistory WalletId
pk [(Tx, TxMeta)]
txh

        , readTxHistory :: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> m [TransactionInfo]
readTxHistory = \WalletId
pk Maybe Coin
minWithdrawal SortOrder
order Range SlotNo
range Maybe TxStatus
mstatus ->
            MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
-> ModelOp
     WalletId s (k 'RootK XPrv, PassphraseHash) [TransactionInfo]
-> m [TransactionInfo]
forall (m :: * -> *) s xprv a.
MonadUnliftIO m =>
MVar (Database WalletId s xprv) -> ModelOp WalletId s xprv a -> m a
readDB MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
db (ModelOp
   WalletId s (k 'RootK XPrv, PassphraseHash) [TransactionInfo]
 -> m [TransactionInfo])
-> ModelOp
     WalletId s (k 'RootK XPrv, PassphraseHash) [TransactionInfo]
-> m [TransactionInfo]
forall a b. (a -> b) -> a -> b
$
                TimeInterpreter Identity
-> WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> ModelOp
     WalletId s (k 'RootK XPrv, PassphraseHash) [TransactionInfo]
forall wid s xprv.
Ord wid =>
TimeInterpreter Identity
-> wid
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> ModelOp wid s xprv [TransactionInfo]
mReadTxHistory
                    TimeInterpreter Identity
timeInterpreter
                    WalletId
pk
                    Maybe Coin
minWithdrawal
                    SortOrder
order
                    Range SlotNo
range
                    Maybe TxStatus
mstatus

        -- TODO: shift implementation to mGetTx
        , getTx :: WalletId
-> Hash "Tx" -> ExceptT ErrNoSuchWallet m (Maybe TransactionInfo)
getTx = \WalletId
pk Hash "Tx"
tid -> m (Either ErrNoSuchWallet (Maybe TransactionInfo))
-> ExceptT ErrNoSuchWallet m (Maybe TransactionInfo)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either ErrNoSuchWallet (Maybe TransactionInfo))
 -> ExceptT ErrNoSuchWallet m (Maybe TransactionInfo))
-> m (Either ErrNoSuchWallet (Maybe TransactionInfo))
-> ExceptT ErrNoSuchWallet m (Maybe TransactionInfo)
forall a b. (a -> b) -> a -> b
$
            (Err WalletId -> Maybe ErrNoSuchWallet)
-> MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
-> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ()
-> m (Either ErrNoSuchWallet ())
forall (m :: * -> *) err s xprv a.
MonadUnliftIO m =>
(Err WalletId -> Maybe err)
-> MVar (Database WalletId s xprv)
-> ModelOp WalletId s xprv a
-> m (Either err a)
alterDB Err WalletId -> Maybe ErrNoSuchWallet
errNoSuchWallet MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
db (WalletId -> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ()
forall wid s xprv. Ord wid => wid -> ModelOp wid s xprv ()
mCheckWallet WalletId
pk) m (Either ErrNoSuchWallet ())
-> (Either ErrNoSuchWallet ()
    -> m (Either ErrNoSuchWallet (Maybe TransactionInfo)))
-> m (Either ErrNoSuchWallet (Maybe TransactionInfo))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Left ErrNoSuchWallet
err -> Either ErrNoSuchWallet (Maybe TransactionInfo)
-> m (Either ErrNoSuchWallet (Maybe TransactionInfo))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrNoSuchWallet (Maybe TransactionInfo)
 -> m (Either ErrNoSuchWallet (Maybe TransactionInfo)))
-> Either ErrNoSuchWallet (Maybe TransactionInfo)
-> m (Either ErrNoSuchWallet (Maybe TransactionInfo))
forall a b. (a -> b) -> a -> b
$ ErrNoSuchWallet -> Either ErrNoSuchWallet (Maybe TransactionInfo)
forall a b. a -> Either a b
Left ErrNoSuchWallet
err
                Right ()
_ -> do
                    [TransactionInfo]
txInfos <- MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
-> ModelOp
     WalletId s (k 'RootK XPrv, PassphraseHash) [TransactionInfo]
-> m [TransactionInfo]
forall (m :: * -> *) s xprv a.
MonadUnliftIO m =>
MVar (Database WalletId s xprv) -> ModelOp WalletId s xprv a -> m a
readDB MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
db
                        (ModelOp
   WalletId s (k 'RootK XPrv, PassphraseHash) [TransactionInfo]
 -> m [TransactionInfo])
-> ModelOp
     WalletId s (k 'RootK XPrv, PassphraseHash) [TransactionInfo]
-> m [TransactionInfo]
forall a b. (a -> b) -> a -> b
$ TimeInterpreter Identity
-> WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> ModelOp
     WalletId s (k 'RootK XPrv, PassphraseHash) [TransactionInfo]
forall wid s xprv.
Ord wid =>
TimeInterpreter Identity
-> wid
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> ModelOp wid s xprv [TransactionInfo]
mReadTxHistory
                            TimeInterpreter Identity
timeInterpreter
                            WalletId
pk
                            Maybe Coin
forall a. Maybe a
Nothing
                            SortOrder
Descending
                            Range SlotNo
forall a. Range a
wholeRange
                            Maybe TxStatus
forall a. Maybe a
Nothing
                    let txPresent :: TransactionInfo -> Bool
txPresent (TransactionInfo{[(TxIn, Coin, Maybe TxOut)]
[TxOut]
Maybe TxMetadata
Maybe Coin
Maybe TxScriptValidity
Maybe TxOut
Map RewardAccount Coin
UTCTime
Hash "Tx"
Quantity "block" Natural
TxMeta
$sel:txInfoScriptValidity:TransactionInfo :: TransactionInfo -> Maybe TxScriptValidity
$sel:txInfoMetadata:TransactionInfo :: TransactionInfo -> Maybe TxMetadata
$sel:txInfoTime:TransactionInfo :: TransactionInfo -> UTCTime
$sel:txInfoDepth:TransactionInfo :: TransactionInfo -> Quantity "block" Natural
$sel:txInfoMeta:TransactionInfo :: TransactionInfo -> TxMeta
$sel:txInfoWithdrawals:TransactionInfo :: TransactionInfo -> Map RewardAccount Coin
$sel:txInfoCollateralOutput:TransactionInfo :: TransactionInfo -> Maybe TxOut
$sel:txInfoOutputs:TransactionInfo :: TransactionInfo -> [TxOut]
$sel:txInfoCollateralInputs:TransactionInfo :: TransactionInfo -> [(TxIn, Coin, Maybe TxOut)]
$sel:txInfoInputs:TransactionInfo :: TransactionInfo -> [(TxIn, Coin, Maybe TxOut)]
$sel:txInfoFee:TransactionInfo :: TransactionInfo -> Maybe Coin
$sel:txInfoId:TransactionInfo :: TransactionInfo -> Hash "Tx"
txInfoScriptValidity :: Maybe TxScriptValidity
txInfoMetadata :: Maybe TxMetadata
txInfoTime :: UTCTime
txInfoDepth :: Quantity "block" Natural
txInfoMeta :: TxMeta
txInfoWithdrawals :: Map RewardAccount Coin
txInfoCollateralOutput :: Maybe TxOut
txInfoOutputs :: [TxOut]
txInfoCollateralInputs :: [(TxIn, Coin, Maybe TxOut)]
txInfoInputs :: [(TxIn, Coin, Maybe TxOut)]
txInfoFee :: Maybe Coin
txInfoId :: Hash "Tx"
..}) = Hash "Tx"
txInfoId Hash "Tx" -> Hash "Tx" -> Bool
forall a. Eq a => a -> a -> Bool
== Hash "Tx"
tid
                    case (TransactionInfo -> Bool) -> [TransactionInfo] -> [TransactionInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter TransactionInfo -> Bool
txPresent [TransactionInfo]
txInfos of
                        [] -> Either ErrNoSuchWallet (Maybe TransactionInfo)
-> m (Either ErrNoSuchWallet (Maybe TransactionInfo))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrNoSuchWallet (Maybe TransactionInfo)
 -> m (Either ErrNoSuchWallet (Maybe TransactionInfo)))
-> Either ErrNoSuchWallet (Maybe TransactionInfo)
-> m (Either ErrNoSuchWallet (Maybe TransactionInfo))
forall a b. (a -> b) -> a -> b
$ Maybe TransactionInfo
-> Either ErrNoSuchWallet (Maybe TransactionInfo)
forall a b. b -> Either a b
Right Maybe TransactionInfo
forall a. Maybe a
Nothing
                        TransactionInfo
t:[TransactionInfo]
_ -> Either ErrNoSuchWallet (Maybe TransactionInfo)
-> m (Either ErrNoSuchWallet (Maybe TransactionInfo))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrNoSuchWallet (Maybe TransactionInfo)
 -> m (Either ErrNoSuchWallet (Maybe TransactionInfo)))
-> Either ErrNoSuchWallet (Maybe TransactionInfo)
-> m (Either ErrNoSuchWallet (Maybe TransactionInfo))
forall a b. (a -> b) -> a -> b
$ Maybe TransactionInfo
-> Either ErrNoSuchWallet (Maybe TransactionInfo)
forall a b. b -> Either a b
Right (Maybe TransactionInfo
 -> Either ErrNoSuchWallet (Maybe TransactionInfo))
-> Maybe TransactionInfo
-> Either ErrNoSuchWallet (Maybe TransactionInfo)
forall a b. (a -> b) -> a -> b
$ TransactionInfo -> Maybe TransactionInfo
forall a. a -> Maybe a
Just TransactionInfo
t

        {-----------------------------------------------------------------------
                                       Keystore
        -----------------------------------------------------------------------}

        , putPrivateKey :: WalletId
-> (k 'RootK XPrv, PassphraseHash) -> ExceptT ErrNoSuchWallet m ()
putPrivateKey = \WalletId
pk (k 'RootK XPrv, PassphraseHash)
prv -> m (Either ErrNoSuchWallet ()) -> ExceptT ErrNoSuchWallet m ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either ErrNoSuchWallet ()) -> ExceptT ErrNoSuchWallet m ())
-> m (Either ErrNoSuchWallet ()) -> ExceptT ErrNoSuchWallet m ()
forall a b. (a -> b) -> a -> b
$
            (Err WalletId -> Maybe ErrNoSuchWallet)
-> MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
-> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ()
-> m (Either ErrNoSuchWallet ())
forall (m :: * -> *) err s xprv a.
MonadUnliftIO m =>
(Err WalletId -> Maybe err)
-> MVar (Database WalletId s xprv)
-> ModelOp WalletId s xprv a
-> m (Either err a)
alterDB Err WalletId -> Maybe ErrNoSuchWallet
errNoSuchWallet MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
db (ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ()
 -> m (Either ErrNoSuchWallet ()))
-> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ()
-> m (Either ErrNoSuchWallet ())
forall a b. (a -> b) -> a -> b
$
            WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ()
forall wid xprv s. Ord wid => wid -> xprv -> ModelOp wid s xprv ()
mPutPrivateKey WalletId
pk (k 'RootK XPrv, PassphraseHash)
prv

        , readPrivateKey :: WalletId -> m (Maybe (k 'RootK XPrv, PassphraseHash))
readPrivateKey = MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
-> ModelOp
     WalletId
     s
     (k 'RootK XPrv, PassphraseHash)
     (Maybe (k 'RootK XPrv, PassphraseHash))
-> m (Maybe (k 'RootK XPrv, PassphraseHash))
forall (m :: * -> *) s xprv a.
MonadUnliftIO m =>
MVar (Database WalletId s xprv) -> ModelOp WalletId s xprv a -> m a
readDB MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
db (ModelOp
   WalletId
   s
   (k 'RootK XPrv, PassphraseHash)
   (Maybe (k 'RootK XPrv, PassphraseHash))
 -> m (Maybe (k 'RootK XPrv, PassphraseHash)))
-> (WalletId
    -> ModelOp
         WalletId
         s
         (k 'RootK XPrv, PassphraseHash)
         (Maybe (k 'RootK XPrv, PassphraseHash)))
-> WalletId
-> m (Maybe (k 'RootK XPrv, PassphraseHash))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WalletId
-> ModelOp
     WalletId
     s
     (k 'RootK XPrv, PassphraseHash)
     (Maybe (k 'RootK XPrv, PassphraseHash))
forall wid s xprv.
Ord wid =>
wid -> ModelOp wid s xprv (Maybe xprv)
mReadPrivateKey

        {-----------------------------------------------------------------------
                                       Pending Tx
        -----------------------------------------------------------------------}

        , putLocalTxSubmission :: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission m ()
putLocalTxSubmission = \WalletId
pk Hash "Tx"
txid SealedTx
tx SlotNo
sl -> m (Either ErrPutLocalTxSubmission ())
-> ExceptT ErrPutLocalTxSubmission m ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either ErrPutLocalTxSubmission ())
 -> ExceptT ErrPutLocalTxSubmission m ())
-> m (Either ErrPutLocalTxSubmission ())
-> ExceptT ErrPutLocalTxSubmission m ()
forall a b. (a -> b) -> a -> b
$
            (Err WalletId -> Maybe ErrPutLocalTxSubmission)
-> MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
-> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ()
-> m (Either ErrPutLocalTxSubmission ())
forall (m :: * -> *) err s xprv a.
MonadUnliftIO m =>
(Err WalletId -> Maybe err)
-> MVar (Database WalletId s xprv)
-> ModelOp WalletId s xprv a
-> m (Either err a)
alterDB ((ErrNoSuchWallet -> ErrPutLocalTxSubmission)
-> Maybe ErrNoSuchWallet -> Maybe ErrPutLocalTxSubmission
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ErrNoSuchWallet -> ErrPutLocalTxSubmission
ErrPutLocalTxSubmissionNoSuchWallet (Maybe ErrNoSuchWallet -> Maybe ErrPutLocalTxSubmission)
-> (Err WalletId -> Maybe ErrNoSuchWallet)
-> Err WalletId
-> Maybe ErrPutLocalTxSubmission
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Err WalletId -> Maybe ErrNoSuchWallet
errNoSuchWallet) MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
db (ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ()
 -> m (Either ErrPutLocalTxSubmission ()))
-> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ()
-> m (Either ErrPutLocalTxSubmission ())
forall a b. (a -> b) -> a -> b
$
            WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ()
forall wid s xprv.
Ord wid =>
wid -> Hash "Tx" -> SealedTx -> SlotNo -> ModelOp wid s xprv ()
mPutLocalTxSubmission WalletId
pk Hash "Tx"
txid SealedTx
tx SlotNo
sl

        , readLocalTxSubmissionPending :: WalletId -> m [LocalTxSubmissionStatus SealedTx]
readLocalTxSubmissionPending =
            MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
-> ModelOp
     WalletId
     s
     (k 'RootK XPrv, PassphraseHash)
     [LocalTxSubmissionStatus SealedTx]
-> m [LocalTxSubmissionStatus SealedTx]
forall (m :: * -> *) s xprv a.
MonadUnliftIO m =>
MVar (Database WalletId s xprv) -> ModelOp WalletId s xprv a -> m a
readDB MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
db (ModelOp
   WalletId
   s
   (k 'RootK XPrv, PassphraseHash)
   [LocalTxSubmissionStatus SealedTx]
 -> m [LocalTxSubmissionStatus SealedTx])
-> (WalletId
    -> ModelOp
         WalletId
         s
         (k 'RootK XPrv, PassphraseHash)
         [LocalTxSubmissionStatus SealedTx])
-> WalletId
-> m [LocalTxSubmissionStatus SealedTx]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WalletId
-> ModelOp
     WalletId
     s
     (k 'RootK XPrv, PassphraseHash)
     [LocalTxSubmissionStatus SealedTx]
forall wid s xprv.
Ord wid =>
wid -> ModelOp wid s xprv [LocalTxSubmissionStatus SealedTx]
mReadLocalTxSubmissionPending

        , updatePendingTxForExpiry :: WalletId -> SlotNo -> ExceptT ErrNoSuchWallet m ()
updatePendingTxForExpiry = \WalletId
pk SlotNo
tip -> m (Either ErrNoSuchWallet ()) -> ExceptT ErrNoSuchWallet m ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either ErrNoSuchWallet ()) -> ExceptT ErrNoSuchWallet m ())
-> m (Either ErrNoSuchWallet ()) -> ExceptT ErrNoSuchWallet m ()
forall a b. (a -> b) -> a -> b
$
            (Err WalletId -> Maybe ErrNoSuchWallet)
-> MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
-> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ()
-> m (Either ErrNoSuchWallet ())
forall (m :: * -> *) err s xprv a.
MonadUnliftIO m =>
(Err WalletId -> Maybe err)
-> MVar (Database WalletId s xprv)
-> ModelOp WalletId s xprv a
-> m (Either err a)
alterDB Err WalletId -> Maybe ErrNoSuchWallet
errNoSuchWallet MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
db (ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ()
 -> m (Either ErrNoSuchWallet ()))
-> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ()
-> m (Either ErrNoSuchWallet ())
forall a b. (a -> b) -> a -> b
$
            WalletId
-> SlotNo -> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ()
forall wid s xprv.
Ord wid =>
wid -> SlotNo -> ModelOp wid s xprv ()
mUpdatePendingTxForExpiry WalletId
pk SlotNo
tip

        , removePendingOrExpiredTx :: WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx m ()
removePendingOrExpiredTx = \WalletId
pk Hash "Tx"
tid -> m (Either ErrRemoveTx ()) -> ExceptT ErrRemoveTx m ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either ErrRemoveTx ()) -> ExceptT ErrRemoveTx m ())
-> m (Either ErrRemoveTx ()) -> ExceptT ErrRemoveTx m ()
forall a b. (a -> b) -> a -> b
$
            (Err WalletId -> Maybe ErrRemoveTx)
-> MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
-> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ()
-> m (Either ErrRemoveTx ())
forall (m :: * -> *) err s xprv a.
MonadUnliftIO m =>
(Err WalletId -> Maybe err)
-> MVar (Database WalletId s xprv)
-> ModelOp WalletId s xprv a
-> m (Either err a)
alterDB Err WalletId -> Maybe ErrRemoveTx
errCannotRemovePendingTx MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
db (ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ()
 -> m (Either ErrRemoveTx ()))
-> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ()
-> m (Either ErrRemoveTx ())
forall a b. (a -> b) -> a -> b
$
            WalletId
-> Hash "Tx"
-> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ()
forall wid s xprv.
Ord wid =>
wid -> Hash "Tx" -> ModelOp wid s xprv ()
mRemovePendingOrExpiredTx WalletId
pk Hash "Tx"
tid

        {-----------------------------------------------------------------------
                                 Protocol Parameters
        -----------------------------------------------------------------------}

        , readGenesisParameters :: WalletId -> m (Maybe GenesisParameters)
readGenesisParameters = MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
-> ModelOp
     WalletId
     s
     (k 'RootK XPrv, PassphraseHash)
     (Maybe GenesisParameters)
-> m (Maybe GenesisParameters)
forall (m :: * -> *) s xprv a.
MonadUnliftIO m =>
MVar (Database WalletId s xprv) -> ModelOp WalletId s xprv a -> m a
readDB MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
db (ModelOp
   WalletId
   s
   (k 'RootK XPrv, PassphraseHash)
   (Maybe GenesisParameters)
 -> m (Maybe GenesisParameters))
-> (WalletId
    -> ModelOp
         WalletId
         s
         (k 'RootK XPrv, PassphraseHash)
         (Maybe GenesisParameters))
-> WalletId
-> m (Maybe GenesisParameters)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WalletId
-> ModelOp
     WalletId
     s
     (k 'RootK XPrv, PassphraseHash)
     (Maybe GenesisParameters)
forall wid s xprv.
Ord wid =>
wid -> ModelOp wid s xprv (Maybe GenesisParameters)
mReadGenesisParameters

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

        , putDelegationRewardBalance :: WalletId -> Coin -> ExceptT ErrNoSuchWallet m ()
putDelegationRewardBalance = \WalletId
pk Coin
amt -> m (Either ErrNoSuchWallet ()) -> ExceptT ErrNoSuchWallet m ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either ErrNoSuchWallet ()) -> ExceptT ErrNoSuchWallet m ())
-> m (Either ErrNoSuchWallet ()) -> ExceptT ErrNoSuchWallet m ()
forall a b. (a -> b) -> a -> b
$
            (Err WalletId -> Maybe ErrNoSuchWallet)
-> MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
-> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ()
-> m (Either ErrNoSuchWallet ())
forall (m :: * -> *) err s xprv a.
MonadUnliftIO m =>
(Err WalletId -> Maybe err)
-> MVar (Database WalletId s xprv)
-> ModelOp WalletId s xprv a
-> m (Either err a)
alterDB Err WalletId -> Maybe ErrNoSuchWallet
errNoSuchWallet MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
db (WalletId
-> Coin -> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) ()
forall wid s xprv. Ord wid => wid -> Coin -> ModelOp wid s xprv ()
mPutDelegationRewardBalance WalletId
pk Coin
amt)

        , readDelegationRewardBalance :: WalletId -> m Coin
readDelegationRewardBalance =
            MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
-> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) Coin
-> m Coin
forall (m :: * -> *) s xprv a.
MonadUnliftIO m =>
MVar (Database WalletId s xprv) -> ModelOp WalletId s xprv a -> m a
readDB MVar (Database WalletId s (k 'RootK XPrv, PassphraseHash))
db (ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) Coin -> m Coin)
-> (WalletId
    -> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) Coin)
-> WalletId
-> m Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WalletId -> ModelOp WalletId s (k 'RootK XPrv, PassphraseHash) Coin
forall wid s xprv. Ord wid => wid -> ModelOp wid s xprv Coin
mReadDelegationRewardBalance

        {-----------------------------------------------------------------------
                                      Execution
        -----------------------------------------------------------------------}

        , atomically :: forall a. m a -> m a
atomically = \m a
action -> MVar () -> (() -> m a) -> m a
forall (m :: * -> *) a b.
MonadUnliftIO m =>
MVar a -> (a -> m b) -> m b
withMVar MVar ()
lock ((() -> m a) -> m a) -> (() -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \() -> m a
action
        }

-- | Apply an operation to the model database, then update the mutable variable.
alterDB
    :: MonadUnliftIO m
    => (Err WalletId -> Maybe err)
    -- ^ Error type converter
    -> MVar (Database WalletId s xprv)
    -- ^ The database variable
    -> ModelOp WalletId s xprv a
    -- ^ Operation to run on the database
    -> m (Either err a)
alterDB :: (Err WalletId -> Maybe err)
-> MVar (Database WalletId s xprv)
-> ModelOp WalletId s xprv a
-> m (Either err a)
alterDB Err WalletId -> Maybe err
convertErr MVar (Database WalletId s xprv)
db ModelOp WalletId s xprv a
op = MVar (Database WalletId s xprv)
-> (Database WalletId s xprv
    -> m (Database WalletId s xprv, Either err a))
-> m (Either err a)
forall (m :: * -> *) a b.
MonadUnliftIO m =>
MVar a -> (a -> m (a, b)) -> m b
modifyMVar MVar (Database WalletId s xprv)
db ((Either (Err WalletId) a, Database WalletId s xprv)
-> m (Database WalletId s xprv, Either err a)
bubble ((Either (Err WalletId) a, Database WalletId s xprv)
 -> m (Database WalletId s xprv, Either err a))
-> ModelOp WalletId s xprv a
-> Database WalletId s xprv
-> m (Database WalletId s xprv, Either err a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModelOp WalletId s xprv a
op)
  where
    bubble :: (Either (Err WalletId) a, Database WalletId s xprv)
-> m (Database WalletId s xprv, Either err a)
bubble (Left Err WalletId
e, !Database WalletId s xprv
db') = case Err WalletId -> Maybe err
convertErr Err WalletId
e of
        Just err
e' -> (Database WalletId s xprv, Either err a)
-> m (Database WalletId s xprv, Either err a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Database WalletId s xprv
db', err -> Either err a
forall a b. a -> Either a b
Left err
e')
        Maybe err
Nothing -> MVarDBError -> m (Database WalletId s xprv, Either err a)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (MVarDBError -> m (Database WalletId s xprv, Either err a))
-> MVarDBError -> m (Database WalletId s xprv, Either err a)
forall a b. (a -> b) -> a -> b
$ Err WalletId -> MVarDBError
MVarDBError Err WalletId
e
    bubble (Right a
a, !Database WalletId s xprv
db') = (Database WalletId s xprv, Either err a)
-> m (Database WalletId s xprv, Either err a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Database WalletId s xprv
db', a -> Either err a
forall a b. b -> Either a b
Right a
a)

-- | Run a query operation on the model database. Any error results are turned
-- into a runtime exception.
readDB
    :: MonadUnliftIO m
    => MVar (Database WalletId s xprv)
    -- ^ The database variable
    -> ModelOp WalletId s xprv a
    -- ^ Operation to run on the database
    -> m a
readDB :: MVar (Database WalletId s xprv) -> ModelOp WalletId s xprv a -> m a
readDB MVar (Database WalletId s xprv)
db ModelOp WalletId s xprv a
op = (Err WalletId -> Maybe (Err WalletId))
-> MVar (Database WalletId s xprv)
-> ModelOp WalletId s xprv a
-> m (Either (Err WalletId) a)
forall (m :: * -> *) err s xprv a.
MonadUnliftIO m =>
(Err WalletId -> Maybe err)
-> MVar (Database WalletId s xprv)
-> ModelOp WalletId s xprv a
-> m (Either err a)
alterDB Err WalletId -> Maybe (Err WalletId)
forall a. a -> Maybe a
Just MVar (Database WalletId s xprv)
db ModelOp WalletId s xprv a
op m (Either (Err WalletId) a)
-> (Either (Err WalletId) a -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Err WalletId -> m a)
-> (a -> m a) -> Either (Err WalletId) a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (MVarDBError -> m a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (MVarDBError -> m a)
-> (Err WalletId -> MVarDBError) -> Err WalletId -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Err WalletId -> MVarDBError
MVarDBError) a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

errNoSuchWallet :: Err WalletId -> Maybe ErrNoSuchWallet
errNoSuchWallet :: Err WalletId -> Maybe ErrNoSuchWallet
errNoSuchWallet (NoSuchWallet WalletId
wid) = ErrNoSuchWallet -> Maybe ErrNoSuchWallet
forall a. a -> Maybe a
Just (WalletId -> ErrNoSuchWallet
ErrNoSuchWallet WalletId
wid)
errNoSuchWallet Err WalletId
_ = Maybe ErrNoSuchWallet
forall a. Maybe a
Nothing

errCannotRemovePendingTx :: Err WalletId -> Maybe ErrRemoveTx
errCannotRemovePendingTx :: Err WalletId -> Maybe ErrRemoveTx
errCannotRemovePendingTx (NoSuchWallet WalletId
wid) =
    ErrRemoveTx -> Maybe ErrRemoveTx
forall a. a -> Maybe a
Just (ErrNoSuchWallet -> ErrRemoveTx
ErrRemoveTxNoSuchWallet (WalletId -> ErrNoSuchWallet
ErrNoSuchWallet WalletId
wid))
errCannotRemovePendingTx (NoSuchTx WalletId
wid Hash "Tx"
tid) =
    ErrRemoveTx -> Maybe ErrRemoveTx
forall a. a -> Maybe a
Just (ErrNoSuchTransaction -> ErrRemoveTx
ErrRemoveTxNoSuchTransaction (WalletId -> Hash "Tx" -> ErrNoSuchTransaction
ErrNoSuchTransaction WalletId
wid Hash "Tx"
tid))
errCannotRemovePendingTx (CantRemoveTxInLedger WalletId
_ Hash "Tx"
tid) =
    ErrRemoveTx -> Maybe ErrRemoveTx
forall a. a -> Maybe a
Just (Hash "Tx" -> ErrRemoveTx
ErrRemoveTxAlreadyInLedger Hash "Tx"
tid)
errCannotRemovePendingTx Err WalletId
_ = Maybe ErrRemoveTx
forall a. Maybe a
Nothing

errWalletAlreadyExists
    :: Err WalletId
    -> Maybe ErrWalletAlreadyExists
errWalletAlreadyExists :: Err WalletId -> Maybe ErrWalletAlreadyExists
errWalletAlreadyExists (WalletAlreadyExists WalletId
wid) =
    ErrWalletAlreadyExists -> Maybe ErrWalletAlreadyExists
forall a. a -> Maybe a
Just (WalletId -> ErrWalletAlreadyExists
ErrWalletAlreadyExists WalletId
wid)
errWalletAlreadyExists Err WalletId
_ = Maybe ErrWalletAlreadyExists
forall a. Maybe a
Nothing

-- | Error which happens when model returns an unexpected value.
newtype MVarDBError = MVarDBError (Err WalletId)
    deriving (Int -> MVarDBError -> ShowS
[MVarDBError] -> ShowS
MVarDBError -> [Char]
(Int -> MVarDBError -> ShowS)
-> (MVarDBError -> [Char])
-> ([MVarDBError] -> ShowS)
-> Show MVarDBError
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [MVarDBError] -> ShowS
$cshowList :: [MVarDBError] -> ShowS
show :: MVarDBError -> [Char]
$cshow :: MVarDBError -> [Char]
showsPrec :: Int -> MVarDBError -> ShowS
$cshowsPrec :: Int -> MVarDBError -> ShowS
Show)

instance Exception MVarDBError