Skip to content

Commit

Permalink
Try #2570:
Browse files Browse the repository at this point in the history
  • Loading branch information
iohk-bors[bot] committed Apr 19, 2021
2 parents 151800b + 0e9623f commit ac5c72b
Show file tree
Hide file tree
Showing 16 changed files with 843 additions and 537 deletions.
12 changes: 11 additions & 1 deletion lib/core/src/Cardano/DB/Sqlite.hs
Original file line number Diff line number Diff line change
Expand Up @@ -34,6 +34,7 @@ module Cardano.DB.Sqlite
-- * Helpers
, chunkSize
, dbChunked
, dbChunkedFor
, dbChunked'
, handleConstraint
, unsafeRunQuery
Expand Down Expand Up @@ -617,7 +618,16 @@ dbChunked
=> ([record] -> SqlPersistT IO b)
-> [record]
-> SqlPersistT IO ()
dbChunked = chunkedM (chunkSizeFor @record)
dbChunked = dbChunkedFor @record

-- | Like 'dbChunked', but generalized for the case where the input list is not
-- the same type as the record.
dbChunkedFor
:: forall record a b. PersistEntity record
=> ([a] -> SqlPersistT IO b)
-> [a]
-> SqlPersistT IO ()
dbChunkedFor = chunkedM (chunkSizeFor @record)

-- | Like 'dbChunked', but allows bundling elements with a 'Key'. Useful when
-- used with 'repsertMany'.
Expand Down
7 changes: 2 additions & 5 deletions lib/core/src/Cardano/Wallet.hs
Original file line number Diff line number Diff line change
Expand Up @@ -187,6 +187,7 @@ import Cardano.Slotting.Slot
( SlotNo (..) )
import Cardano.Wallet.DB
( DBLayer (..)
, ErrNoSuchTransaction (..)
, ErrNoSuchWallet (..)
, ErrRemoveTx (..)
, ErrWalletAlreadyExists (..)
Expand Down Expand Up @@ -1695,7 +1696,7 @@ getTransaction ctx wid tid = db & \DBLayer{..} -> do
Left err -> do
throwE (ErrGetTransactionNoSuchWallet err)
Right Nothing -> do
let err' = ErrNoSuchTransaction tid
let err' = ErrNoSuchTransaction wid tid
throwE (ErrGetTransactionNoSuchTransaction err')
Right (Just tx) ->
pure tx
Expand Down Expand Up @@ -2224,10 +2225,6 @@ data ErrGetTransaction
| ErrGetTransactionNoSuchTransaction ErrNoSuchTransaction
deriving (Show, Eq)

-- | Indicates that the specified transaction hash is not found.
newtype ErrNoSuchTransaction = ErrNoSuchTransaction (Hash "Tx")
deriving (Show, Eq)

-- | Indicates that the specified start time is later than the specified end
-- time.
data ErrStartTimeLaterThanEndTime = ErrStartTimeLaterThanEndTime
Expand Down
4 changes: 2 additions & 2 deletions lib/core/src/Cardano/Wallet/Api/Server.hs
Original file line number Diff line number Diff line change
Expand Up @@ -2864,7 +2864,7 @@ instance IsServerError ErrSubmitExternalTx where
instance IsServerError ErrRemoveTx where
toServerError = \case
ErrRemoveTxNoSuchWallet wid -> toServerError wid
ErrRemoveTxNoSuchTransaction tid ->
ErrRemoveTxNoSuchTransaction (ErrNoSuchTransaction _wid tid) ->
apiError err404 NoSuchTransaction $ mconcat
[ "I couldn't find a transaction with the given id: "
, toText tid
Expand Down Expand Up @@ -2942,7 +2942,7 @@ instance IsServerError ErrGetTransaction where

instance IsServerError ErrNoSuchTransaction where
toServerError = \case
ErrNoSuchTransaction tid ->
ErrNoSuchTransaction _wid tid ->
apiError err404 NoSuchTransaction $ mconcat
[ "I couldn't find a transaction with the given id: "
, toText tid
Expand Down
54 changes: 46 additions & 8 deletions lib/core/src/Cardano/Wallet/DB.hs
Original file line number Diff line number Diff line change
@@ -1,4 +1,6 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
Expand Down Expand Up @@ -27,9 +29,11 @@ module Cardano.Wallet.DB
, gapSize

-- * Errors
, ErrRemoveTx (..)
, ErrNoSuchWallet(..)
, ErrWalletAlreadyExists(..)
, ErrNoSuchTransaction (..)
, ErrRemoveTx (..)
, ErrPutLocalTxSubmission (..)
) where

import Prelude
Expand All @@ -55,7 +59,15 @@ import Cardano.Wallet.Primitive.Types.Coin
import Cardano.Wallet.Primitive.Types.Hash
( Hash )
import Cardano.Wallet.Primitive.Types.Tx
( TransactionInfo, Tx (..), TxMeta, TxStatus )
( LocalTxSubmissionStatus
, SealedTx
, TransactionInfo
, Tx (..)
, TxMeta
, TxStatus
)
import Control.DeepSeq
( NFData )
import Control.Monad.IO.Class
( MonadIO )
import Control.Monad.Trans.Except
Expand All @@ -64,6 +76,8 @@ import Data.Quantity
( Quantity (..) )
import Data.Word
( Word32, Word8 )
import GHC.Generics
( Generic )

import qualified Data.List as L

Expand Down Expand Up @@ -242,6 +256,23 @@ data DBLayer m s k = forall stm. (MonadIO stm, MonadFail stm) => DBLayer
--
-- If the wallet doesn't exist, this operation returns an error.

, putLocalTxSubmission
:: PrimaryKey WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission stm ()
-- ^ Add or update a transaction in the local submission pool with the
-- most recent submission slot.

, readLocalTxSubmissionPending
:: PrimaryKey WalletId
-> stm [LocalTxSubmissionStatus SealedTx]
-- ^ List all transactions from the local submission pool which are
-- still pending as of the latest checkpoint of the given wallet. The
-- slot numbers for first submission and most recent submission are
-- included.

, updatePendingTxForExpiry
:: PrimaryKey WalletId
-> SlotNo
Expand Down Expand Up @@ -305,16 +336,23 @@ newtype ErrNoSuchWallet
= ErrNoSuchWallet WalletId -- Wallet is gone or doesn't exist yet
deriving (Eq, Show)

-- | Can't add a transaction to the local tx submission pool.
data ErrPutLocalTxSubmission
= ErrPutLocalTxSubmissionNoSuchWallet ErrNoSuchWallet
| ErrPutLocalTxSubmissionNoSuchTransaction ErrNoSuchTransaction
deriving (Eq, Show)

-- | Can't remove pending or expired transaction.
data ErrRemoveTx
= ErrRemoveTxNoSuchWallet ErrNoSuchWallet
| ErrRemoveTxNoSuchTransaction (Hash "Tx")
| ErrRemoveTxNoSuchTransaction ErrNoSuchTransaction
| ErrRemoveTxAlreadyInLedger (Hash "Tx")
deriving (Eq, Show)

-- | Can't perform given operation because there's no transaction
newtype ErrNoSuchTransaction
= ErrNoSuchTransaction (Hash "Tx")
-- | Indicates that the specified transaction hash is not found in the
-- transaction history of the given wallet.
data ErrNoSuchTransaction
= ErrNoSuchTransaction WalletId (Hash "Tx")
deriving (Eq, Show)

-- | Forbidden operation was executed on an already existing wallet
Expand All @@ -330,8 +368,8 @@ newtype ErrWalletAlreadyExists
-- functions like 'enqueueCheckpoint' needs to be associated to a corresponding
-- wallet. Some other may not because they are information valid for all wallets
-- (like for instance, the last known network tip).
newtype PrimaryKey key = PrimaryKey key
deriving (Show, Eq, Ord)
newtype PrimaryKey key = PrimaryKey { unPrimaryKey :: key }
deriving (Show, Eq, Ord, Generic, NFData)

-- | Clean a database by removing all wallets.
cleanDB :: DBLayer m s k -> m ()
Expand Down
73 changes: 47 additions & 26 deletions lib/core/src/Cardano/Wallet/DB/MVar.hs
Original file line number Diff line number Diff line change
Expand Up @@ -22,7 +22,9 @@ import Cardano.Address.Derivation
( XPrv )
import Cardano.Wallet.DB
( DBLayer (..)
, ErrNoSuchTransaction (..)
, ErrNoSuchWallet (..)
, ErrPutLocalTxSubmission (..)
, ErrRemoveTx (..)
, ErrWalletAlreadyExists (..)
, PrimaryKey (..)
Expand All @@ -40,12 +42,14 @@ import Cardano.Wallet.DB.Model
, mPutCheckpoint
, mPutDelegationCertificate
, mPutDelegationRewardBalance
, mPutLocalTxSubmission
, mPutPrivateKey
, mPutTxHistory
, mPutWalletMeta
, mReadCheckpoint
, mReadDelegationRewardBalance
, mReadGenesisParameters
, mReadLocalTxSubmissionPending
, mReadPrivateKey
, mReadTxHistory
, mReadWalletMeta
Expand All @@ -65,7 +69,7 @@ import Cardano.Wallet.Primitive.Types.Hash
import Cardano.Wallet.Primitive.Types.Tx
( TransactionInfo (..) )
import Control.DeepSeq
( NFData, deepseq )
( NFData, force )
import Control.Monad.Trans.Except
( ExceptT (..) )
import Data.Functor.Identity
Expand All @@ -90,9 +94,9 @@ newDBLayer timeInterpreter = do
Wallets
-----------------------------------------------------------------------}

{ initializeWallet = \pk cp meta txs gp -> ExceptT $ do
cp `deepseq` meta `deepseq`
alterDB errWalletAlreadyExists db (mInitializeWallet pk cp meta txs gp)
{ initializeWallet = \pk cp meta txs gp -> ExceptT $
alterDB errWalletAlreadyExists db $
mInitializeWallet pk cp meta txs gp

, removeWallet = ExceptT . alterDB errNoSuchWallet db . mRemoveWallet

Expand All @@ -102,30 +106,33 @@ newDBLayer timeInterpreter = do
Checkpoints
-----------------------------------------------------------------------}

, putCheckpoint = \pk cp -> ExceptT $ do
cp `deepseq` alterDB errNoSuchWallet db (mPutCheckpoint pk cp)
, putCheckpoint = \pk cp -> ExceptT $
alterDB errNoSuchWallet db $
mPutCheckpoint pk cp

, readCheckpoint = readDB db . mReadCheckpoint

, listCheckpoints = readDB db . mListCheckpoints

, rollbackTo = \pk pt -> ExceptT $
alterDB errNoSuchWallet db (mRollbackTo pk pt)
alterDB errNoSuchWallet db $
mRollbackTo pk pt

, prune = \_ _ -> error "MVar.prune: not implemented"

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

, putWalletMeta = \pk meta -> ExceptT $ do
meta `deepseq` alterDB errNoSuchWallet db (mPutWalletMeta pk meta)
, putWalletMeta = \pk meta -> ExceptT $
alterDB errNoSuchWallet db $
mPutWalletMeta pk meta

, readWalletMeta = readDB db . mReadWalletMeta timeInterpreter

, putDelegationCertificate = \pk cert sl -> ExceptT $ do
cert `deepseq` sl `deepseq`
alterDB errNoSuchWallet db (mPutDelegationCertificate pk cert sl)
, putDelegationCertificate = \pk cert sl -> ExceptT $
alterDB errNoSuchWallet db $
mPutDelegationCertificate pk cert sl

, isStakeKeyRegistered =
ExceptT . alterDB errNoSuchWallet db . mIsStakeKeyRegistered
Expand All @@ -134,8 +141,9 @@ newDBLayer timeInterpreter = do
Tx History
-----------------------------------------------------------------------}

, putTxHistory = \pk txh -> ExceptT $ do
txh `deepseq` alterDB errNoSuchWallet db (mPutTxHistory pk txh)
, putTxHistory = \pk txh -> ExceptT $
alterDB errNoSuchWallet db $
mPutTxHistory pk txh

, readTxHistory = \pk minWithdrawal order range mstatus ->
readDB db $
Expand All @@ -147,6 +155,7 @@ newDBLayer timeInterpreter = do
range
mstatus

-- TODO: shift implementation to mGetTx
, getTx = \pk tid -> ExceptT $
alterDB errNoSuchWallet db (mCheckWallet pk) >>= \case
Left err -> pure $ Left err
Expand All @@ -168,20 +177,30 @@ newDBLayer timeInterpreter = do
Keystore
-----------------------------------------------------------------------}

, putPrivateKey = \pk prv -> ExceptT $ do
prv `deepseq` alterDB errNoSuchWallet db (mPutPrivateKey pk prv)
, putPrivateKey = \pk prv -> ExceptT $
alterDB errNoSuchWallet db $
mPutPrivateKey pk prv

, readPrivateKey = readDB db . mReadPrivateKey

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

, updatePendingTxForExpiry = \pk tip -> ExceptT $ do
alterDB errNoSuchWallet db (mUpdatePendingTxForExpiry pk tip)
, putLocalTxSubmission = \pk txid tx sl -> ExceptT $
alterDB (fmap ErrPutLocalTxSubmissionNoSuchWallet . errNoSuchWallet) db $
mPutLocalTxSubmission pk txid tx sl

, removePendingOrExpiredTx = \pk tid -> ExceptT $ do
alterDB errCannotRemovePendingTx db (mRemovePendingOrExpiredTx pk tid)
, readLocalTxSubmissionPending =
readDB db . mReadLocalTxSubmissionPending

, updatePendingTxForExpiry = \pk tip -> ExceptT $
alterDB errNoSuchWallet db $
mUpdatePendingTxForExpiry pk tip

, removePendingOrExpiredTx = \pk tid -> ExceptT $
alterDB errCannotRemovePendingTx db $
mRemovePendingOrExpiredTx pk tid

{-----------------------------------------------------------------------
Protocol Parameters
Expand All @@ -208,7 +227,8 @@ newDBLayer timeInterpreter = do

-- | Apply an operation to the model database, then update the mutable variable.
alterDB
:: (Err (PrimaryKey WalletId) -> Maybe err)
:: (NFData s, NFData xprv)
=> (Err (PrimaryKey WalletId) -> Maybe err)
-- ^ Error type converter
-> MVar (Database (PrimaryKey WalletId) s xprv)
-- ^ The database variable
Expand All @@ -218,14 +238,15 @@ alterDB
alterDB convertErr db op = modifyMVar db (bubble . op)
where
bubble (Left e, db') = case convertErr e of
Just e' -> pure (db', Left e')
Just e' -> pure (force db', Left e')
Nothing -> throwIO $ MVarDBError e
bubble (Right a, db') = pure (db', Right a)
bubble (Right a, db') = pure (force db', Right a)

-- | Run a query operation on the model database. Any error results are turned
-- into a runtime exception.
readDB
:: MVar (Database (PrimaryKey WalletId) s xprv)
:: (NFData s, NFData xprv)
=> MVar (Database (PrimaryKey WalletId) s xprv)
-- ^ The database variable
-> ModelOp (PrimaryKey WalletId) s xprv a
-- ^ Operation to run on the database
Expand All @@ -239,8 +260,8 @@ errNoSuchWallet _ = Nothing
errCannotRemovePendingTx :: Err (PrimaryKey WalletId) -> Maybe ErrRemoveTx
errCannotRemovePendingTx (NoSuchWallet (PrimaryKey wid)) =
Just (ErrRemoveTxNoSuchWallet (ErrNoSuchWallet wid))
errCannotRemovePendingTx (NoSuchTx _ tid) =
Just (ErrRemoveTxNoSuchTransaction tid)
errCannotRemovePendingTx (NoSuchTx (PrimaryKey wid) tid) =
Just (ErrRemoveTxNoSuchTransaction (ErrNoSuchTransaction wid tid))
errCannotRemovePendingTx (CantRemoveTxInLedger _ tid) =
Just (ErrRemoveTxAlreadyInLedger tid)
errCannotRemovePendingTx _ = Nothing
Expand Down

0 comments on commit ac5c72b

Please sign in to comment.