{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
module Cardano.Wallet.DB
(
DBLayer (..)
, DBFactory (..)
, cleanDB
, ErrBadFormat(..)
, ErrWalletAlreadyExists(..)
, ErrNoSuchTransaction (..)
, ErrRemoveTx (..)
, ErrPutLocalTxSubmission (..)
) where
import Prelude
import Cardano.Address.Derivation
( XPrv )
import Cardano.Wallet.DB.WalletState
( DeltaMap, DeltaWalletState, ErrNoSuchWallet (..) )
import Cardano.Wallet.Primitive.AddressDerivation
( Depth (..) )
import Cardano.Wallet.Primitive.Model
( Wallet )
import Cardano.Wallet.Primitive.Passphrase
( PassphraseHash )
import Cardano.Wallet.Primitive.Types
( ChainPoint
, DelegationCertificate
, GenesisParameters
, Range (..)
, Slot
, SlotNo (..)
, SortOrder (..)
, WalletId
, WalletMetadata
)
import Cardano.Wallet.Primitive.Types.Coin
( Coin )
import Cardano.Wallet.Primitive.Types.Hash
( Hash )
import Cardano.Wallet.Primitive.Types.Tx
( LocalTxSubmissionStatus
, SealedTx
, TransactionInfo
, Tx (..)
, TxMeta
, TxStatus
)
import Control.Monad.IO.Class
( MonadIO )
import Control.Monad.Trans.Except
( ExceptT, runExceptT )
import Data.DBVar
( DBVar )
import Data.Quantity
( Quantity (..) )
import Data.Word
( Word32 )
import UnliftIO.Exception
( Exception )
data DBFactory m s k = DBFactory
{ DBFactory m s k
-> forall a. WalletId -> (DBLayer m s k -> IO a) -> IO a
withDatabase :: forall a. WalletId -> (DBLayer m s k -> IO a) -> IO a
, DBFactory m s k -> WalletId -> IO ()
removeDatabase :: WalletId -> IO ()
, DBFactory m s k -> IO [WalletId]
listDatabases :: IO [WalletId]
}
data DBLayer m s k = forall stm. (MonadIO stm, MonadFail stm) => DBLayer
{ ()
initializeWallet
:: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists stm ()
, ()
removeWallet
:: WalletId
-> ExceptT ErrNoSuchWallet stm ()
, ()
listWallets
:: stm [WalletId]
, ()
walletsDB
:: DBVar stm (DeltaMap WalletId (DeltaWalletState s))
, ()
putCheckpoint
:: WalletId
-> Wallet s
-> ExceptT ErrNoSuchWallet stm ()
, ()
readCheckpoint
:: WalletId
-> stm (Maybe (Wallet s))
, ()
listCheckpoints
:: WalletId
-> stm [ChainPoint]
, ()
putWalletMeta
:: WalletId
-> WalletMetadata
-> ExceptT ErrNoSuchWallet stm ()
, ()
readWalletMeta
:: WalletId
-> stm (Maybe WalletMetadata)
, ()
isStakeKeyRegistered
:: WalletId
-> ExceptT ErrNoSuchWallet stm Bool
, ()
putDelegationCertificate
:: WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
, ()
putDelegationRewardBalance
:: WalletId
-> Coin
-> ExceptT ErrNoSuchWallet stm ()
, ()
readDelegationRewardBalance
:: WalletId
-> stm Coin
, ()
putTxHistory
:: WalletId
-> [(Tx, TxMeta)]
-> ExceptT ErrNoSuchWallet stm ()
, ()
readTxHistory
:: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> stm [TransactionInfo]
, ()
getTx
:: WalletId
-> Hash "Tx"
-> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo)
, ()
putLocalTxSubmission
:: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
, ()
readLocalTxSubmissionPending
:: WalletId
-> stm [LocalTxSubmissionStatus SealedTx]
, ()
updatePendingTxForExpiry
:: WalletId
-> SlotNo
-> ExceptT ErrNoSuchWallet stm ()
, ()
removePendingOrExpiredTx
:: WalletId
-> Hash "Tx"
-> ExceptT ErrRemoveTx stm ()
, ()
putPrivateKey
:: WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet stm ()
, ()
readPrivateKey
:: WalletId
-> stm (Maybe (k 'RootK XPrv, PassphraseHash))
, ()
readGenesisParameters
:: WalletId
-> stm (Maybe GenesisParameters)
, ()
rollbackTo
:: WalletId
-> Slot
-> ExceptT ErrNoSuchWallet stm ChainPoint
, ()
prune
:: WalletId
-> Quantity "block" Word32
-> ExceptT ErrNoSuchWallet stm ()
, ()
atomically
:: forall a. stm a -> m a
}
data ErrBadFormat
= ErrBadFormatAddressPrologue
| ErrBadFormatCheckpoints
deriving (ErrBadFormat -> ErrBadFormat -> Bool
(ErrBadFormat -> ErrBadFormat -> Bool)
-> (ErrBadFormat -> ErrBadFormat -> Bool) -> Eq ErrBadFormat
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrBadFormat -> ErrBadFormat -> Bool
$c/= :: ErrBadFormat -> ErrBadFormat -> Bool
== :: ErrBadFormat -> ErrBadFormat -> Bool
$c== :: ErrBadFormat -> ErrBadFormat -> Bool
Eq,Int -> ErrBadFormat -> ShowS
[ErrBadFormat] -> ShowS
ErrBadFormat -> String
(Int -> ErrBadFormat -> ShowS)
-> (ErrBadFormat -> String)
-> ([ErrBadFormat] -> ShowS)
-> Show ErrBadFormat
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrBadFormat] -> ShowS
$cshowList :: [ErrBadFormat] -> ShowS
show :: ErrBadFormat -> String
$cshow :: ErrBadFormat -> String
showsPrec :: Int -> ErrBadFormat -> ShowS
$cshowsPrec :: Int -> ErrBadFormat -> ShowS
Show)
instance Exception ErrBadFormat
data ErrPutLocalTxSubmission
= ErrPutLocalTxSubmissionNoSuchWallet ErrNoSuchWallet
| ErrPutLocalTxSubmissionNoSuchTransaction ErrNoSuchTransaction
deriving (ErrPutLocalTxSubmission -> ErrPutLocalTxSubmission -> Bool
(ErrPutLocalTxSubmission -> ErrPutLocalTxSubmission -> Bool)
-> (ErrPutLocalTxSubmission -> ErrPutLocalTxSubmission -> Bool)
-> Eq ErrPutLocalTxSubmission
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrPutLocalTxSubmission -> ErrPutLocalTxSubmission -> Bool
$c/= :: ErrPutLocalTxSubmission -> ErrPutLocalTxSubmission -> Bool
== :: ErrPutLocalTxSubmission -> ErrPutLocalTxSubmission -> Bool
$c== :: ErrPutLocalTxSubmission -> ErrPutLocalTxSubmission -> Bool
Eq, Int -> ErrPutLocalTxSubmission -> ShowS
[ErrPutLocalTxSubmission] -> ShowS
ErrPutLocalTxSubmission -> String
(Int -> ErrPutLocalTxSubmission -> ShowS)
-> (ErrPutLocalTxSubmission -> String)
-> ([ErrPutLocalTxSubmission] -> ShowS)
-> Show ErrPutLocalTxSubmission
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrPutLocalTxSubmission] -> ShowS
$cshowList :: [ErrPutLocalTxSubmission] -> ShowS
show :: ErrPutLocalTxSubmission -> String
$cshow :: ErrPutLocalTxSubmission -> String
showsPrec :: Int -> ErrPutLocalTxSubmission -> ShowS
$cshowsPrec :: Int -> ErrPutLocalTxSubmission -> ShowS
Show)
data ErrRemoveTx
= ErrRemoveTxNoSuchWallet ErrNoSuchWallet
| ErrRemoveTxNoSuchTransaction ErrNoSuchTransaction
| ErrRemoveTxAlreadyInLedger (Hash "Tx")
deriving (ErrRemoveTx -> ErrRemoveTx -> Bool
(ErrRemoveTx -> ErrRemoveTx -> Bool)
-> (ErrRemoveTx -> ErrRemoveTx -> Bool) -> Eq ErrRemoveTx
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrRemoveTx -> ErrRemoveTx -> Bool
$c/= :: ErrRemoveTx -> ErrRemoveTx -> Bool
== :: ErrRemoveTx -> ErrRemoveTx -> Bool
$c== :: ErrRemoveTx -> ErrRemoveTx -> Bool
Eq, Int -> ErrRemoveTx -> ShowS
[ErrRemoveTx] -> ShowS
ErrRemoveTx -> String
(Int -> ErrRemoveTx -> ShowS)
-> (ErrRemoveTx -> String)
-> ([ErrRemoveTx] -> ShowS)
-> Show ErrRemoveTx
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrRemoveTx] -> ShowS
$cshowList :: [ErrRemoveTx] -> ShowS
show :: ErrRemoveTx -> String
$cshow :: ErrRemoveTx -> String
showsPrec :: Int -> ErrRemoveTx -> ShowS
$cshowsPrec :: Int -> ErrRemoveTx -> ShowS
Show)
data ErrNoSuchTransaction
= ErrNoSuchTransaction WalletId (Hash "Tx")
deriving (ErrNoSuchTransaction -> ErrNoSuchTransaction -> Bool
(ErrNoSuchTransaction -> ErrNoSuchTransaction -> Bool)
-> (ErrNoSuchTransaction -> ErrNoSuchTransaction -> Bool)
-> Eq ErrNoSuchTransaction
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrNoSuchTransaction -> ErrNoSuchTransaction -> Bool
$c/= :: ErrNoSuchTransaction -> ErrNoSuchTransaction -> Bool
== :: ErrNoSuchTransaction -> ErrNoSuchTransaction -> Bool
$c== :: ErrNoSuchTransaction -> ErrNoSuchTransaction -> Bool
Eq, Int -> ErrNoSuchTransaction -> ShowS
[ErrNoSuchTransaction] -> ShowS
ErrNoSuchTransaction -> String
(Int -> ErrNoSuchTransaction -> ShowS)
-> (ErrNoSuchTransaction -> String)
-> ([ErrNoSuchTransaction] -> ShowS)
-> Show ErrNoSuchTransaction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrNoSuchTransaction] -> ShowS
$cshowList :: [ErrNoSuchTransaction] -> ShowS
show :: ErrNoSuchTransaction -> String
$cshow :: ErrNoSuchTransaction -> String
showsPrec :: Int -> ErrNoSuchTransaction -> ShowS
$cshowsPrec :: Int -> ErrNoSuchTransaction -> ShowS
Show)
newtype ErrWalletAlreadyExists
= ErrWalletAlreadyExists WalletId
deriving (ErrWalletAlreadyExists -> ErrWalletAlreadyExists -> Bool
(ErrWalletAlreadyExists -> ErrWalletAlreadyExists -> Bool)
-> (ErrWalletAlreadyExists -> ErrWalletAlreadyExists -> Bool)
-> Eq ErrWalletAlreadyExists
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrWalletAlreadyExists -> ErrWalletAlreadyExists -> Bool
$c/= :: ErrWalletAlreadyExists -> ErrWalletAlreadyExists -> Bool
== :: ErrWalletAlreadyExists -> ErrWalletAlreadyExists -> Bool
$c== :: ErrWalletAlreadyExists -> ErrWalletAlreadyExists -> Bool
Eq, Int -> ErrWalletAlreadyExists -> ShowS
[ErrWalletAlreadyExists] -> ShowS
ErrWalletAlreadyExists -> String
(Int -> ErrWalletAlreadyExists -> ShowS)
-> (ErrWalletAlreadyExists -> String)
-> ([ErrWalletAlreadyExists] -> ShowS)
-> Show ErrWalletAlreadyExists
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrWalletAlreadyExists] -> ShowS
$cshowList :: [ErrWalletAlreadyExists] -> ShowS
show :: ErrWalletAlreadyExists -> String
$cshow :: ErrWalletAlreadyExists -> String
showsPrec :: Int -> ErrWalletAlreadyExists -> ShowS
$cshowsPrec :: Int -> ErrWalletAlreadyExists -> ShowS
Show)
cleanDB :: DBLayer m s k -> m ()
cleanDB :: DBLayer m s k -> m ()
cleanDB 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 :: ()
..} = stm () -> m ()
forall a. stm a -> m a
atomically (stm () -> m ()) -> stm () -> m ()
forall a b. (a -> b) -> a -> b
$
stm [WalletId]
listWallets stm [WalletId] -> ([WalletId] -> stm ()) -> stm ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (WalletId -> stm (Either ErrNoSuchWallet ()))
-> [WalletId] -> stm ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (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 ()))
-> (WalletId -> ExceptT ErrNoSuchWallet stm ())
-> WalletId
-> stm (Either ErrNoSuchWallet ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WalletId -> ExceptT ErrNoSuchWallet stm ()
removeWallet)