Skip to content
Permalink
Browse files

add invariant to 'PutTxHistory' and actually store pending txs when s…

…toring checkpoint
  • Loading branch information...
KtorZ committed Jun 12, 2019
1 parent 9ae58b8 commit 378313fb03d3048b560883b7f8a81d229ee53844
@@ -6,7 +6,6 @@
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- Copyright: © 2018-2019 IOHK
@@ -607,17 +606,14 @@ newWalletLayer block0 db nw tl = do
throwE $ ErrSignTx e

_submitTx
:: (TxId t)
=> WalletId
:: WalletId
-> (Tx, TxMeta, [TxWitness])
-> ExceptT ErrSubmitTx IO ()
_submitTx wid (tx, meta, wit) = do
withExceptT ErrSubmitTxNetwork $ postTx nw (tx, wit)
DB.withLock db $ withExceptT ErrSubmitTxNoSuchWallet $ do
(w, _) <- _readWallet wid
let history = Map.fromList [(txId @t tx, (tx, meta))]
DB.putCheckpoint db (PrimaryKey wid) (newPending tx w)
DB.putTxHistory db (PrimaryKey wid) history
DB.putCheckpoint db (PrimaryKey wid) (newPending (tx, meta) w)

{---------------------------------------------------------------------------
Keystore
@@ -84,6 +84,8 @@ import Data.Generics.Internal.VL.Lens
( (^.) )
import Data.List.Split
( chunksOf )
import Data.Map.Strict
( Map )
import Data.Quantity
( Quantity (..) )
import Data.Text
@@ -242,10 +244,9 @@ newDBLayer fp = do
selectLatestCheckpoint wid >>= \case
Just cp -> do
utxo <- selectUTxO cp
pendings <- selectPending cp
(ins, outs) <- selectTxs pendings
txs <- selectTxHistory wid [TxMetaTableStatus ==. W.Pending]
s <- selectState (checkpointId cp)
pure (checkpointFromEntity cp utxo ins outs <$> s)
pure (checkpointFromEntity cp utxo txs <$> s)
Nothing -> pure Nothing

{-----------------------------------------------------------------------
@@ -274,15 +275,19 @@ newDBLayer fp = do
ExceptT $ runQuery' $
selectWallet wid >>= \case
Just _ -> do
let (metas, txins, txouts) = mkTxHistory wid txs
let (metas, txins, txouts) = mkTxHistory wid $ W.invariant
("putTxHistory has been called with pending txs: "
<> show txs)
txs
(not . foldl (\b a -> (b || W.isPending a)) False)
putTxMetas metas
putTxs txins txouts
pure $ Right ()
Nothing -> pure $ Left $ ErrNoSuchWallet wid

, readTxHistory = \(PrimaryKey wid) ->
runQuery' $
selectTxHistory wid
selectTxHistory wid []

{-----------------------------------------------------------------------
Keystore
@@ -385,12 +390,15 @@ mkCheckpointEntity
:: forall s t. W.TxId t
=> W.WalletId
-> W.Wallet s t
-> (Checkpoint, [UTxO], [TxIn], [TxOut])
-> (Checkpoint, [UTxO], [TxIn], [TxOut], [TxMeta])
mkCheckpointEntity wid wal =
(cp, utxo, ins, outs)
(cp, utxo, ins, outs, metas)
where
pending = [(W.txId @t tx, tx) | tx <- Set.toList (W.getPending wal)]
(ins, outs) = mkTxInputsOutputs pending
pending =
[ (W.txId @t tx, (tx, meta))
| (tx, meta) <- Set.toList (W.getPending wal)
]
(metas, ins, outs) = mkTxHistory wid (Map.fromList pending)
header = (W.currentTip wal)
sl = header ^. #slotId
parent = header ^. #prevBlockHash
@@ -409,29 +417,21 @@ checkpointFromEntity
:: forall s t. (W.IsOurs s, NFData s, Show s, W.TxId t)
=> Checkpoint
-> [UTxO]
-> [TxIn]
-> [TxOut]
-> Map (W.Hash "Tx") (W.Tx, W.TxMeta)
-> s
-> W.Wallet s t
checkpointFromEntity (Checkpoint _ slot (BlockId parentHeaderHash)) utxo ins outs =
checkpointFromEntity (Checkpoint _ slot (BlockId parentHeaderHash)) utxo txs =
W.unsafeInitWallet utxo' pending (W.BlockHeader slot parentHeaderHash)
where
utxo' = W.UTxO . Map.fromList $
[ (W.TxIn input ix, W.TxOut addr coin)
| UTxO _ _ (TxId input) ix addr coin <- utxo ]
ins' = [(txid, W.TxIn src ix) | TxIn txid _ (TxId src) ix <- ins]
outs' = [ (txid, W.TxOut addr amt)
| TxOut txid _ix addr amt <- outs ]
txids = Set.fromList $ map fst ins' ++ map fst outs'
pending = flip Set.map txids $ \txid -> W.Tx
{ W.inputs = lookupTx txid ins'
, W.outputs = lookupTx txid outs'
}
lookupTx txid = map snd . filter ((== txid) . fst)
| UTxO _ _ (TxId input) ix addr coin <- utxo
]
pending = Set.fromList $ Map.elems txs

mkTxHistory
:: W.WalletId
-> Map.Map (W.Hash "Tx") (W.Tx, W.TxMeta)
-> Map (W.Hash "Tx") (W.Tx, W.TxMeta)
-> ([TxMeta], [TxIn], [TxOut])
mkTxHistory wid txs = (map (uncurry (mkTxMetaEntity wid)) metas, ins, outs)
where
@@ -481,7 +481,7 @@ txHistoryFromEntity
:: [TxMeta]
-> [TxIn]
-> [TxOut]
-> Map.Map (W.Hash "Tx") (W.Tx, W.TxMeta)
-> Map (W.Hash "Tx") (W.Tx, W.TxMeta)
txHistoryFromEntity metas ins outs = Map.fromList
[ (getTxId (txMetaTableTxId m), (mkTx (txMetaTableTxId m), mkTxMeta m))
| m <- metas ]
@@ -517,8 +517,9 @@ insertCheckpoint
-> W.Wallet s t
-> SqlPersistM ()
insertCheckpoint wid cp = do
let (cp', utxo, ins, outs) = mkCheckpointEntity wid cp
let (cp', utxo, ins, outs, metas) = mkCheckpointEntity wid cp
insert_ cp'
putTxMetas metas
putTxs ins outs
dbChunked insertMany_ utxo
insertState (wid, (W.currentTip cp) ^. #slotId) (W.getState cp)
@@ -642,15 +643,6 @@ selectUTxO (Checkpoint wid sl _parent) = fmap entityVal <$>
, UtxoTableCheckpointSlot ==. sl
] []

selectPending
:: Checkpoint
-> SqlPersistM [TxId]
selectPending (Checkpoint wid _ _) = fmap (txMetaTableTxId . entityVal) <$>
selectList
[ TxMetaTableWalletId ==. wid
, TxMetaTableStatus ==. W.Pending
] []

selectTxs
:: [TxId]
-> SqlPersistM ([TxIn], [TxOut])
@@ -663,9 +655,11 @@ selectTxs txids = do

selectTxHistory
:: W.WalletId
-> SqlPersistM (Map.Map (W.Hash "Tx") (W.Tx, W.TxMeta))
selectTxHistory wid = do
metas <- fmap entityVal <$> selectList [TxMetaTableWalletId ==. wid] []
-> [Filter TxMeta]
-> SqlPersistM (Map (W.Hash "Tx") (W.Tx, W.TxMeta))
selectTxHistory wid conditions = do
metas <- fmap entityVal <$> selectList
((TxMetaTableWalletId ==. wid) : conditions) []
let txids = map txMetaTableTxId metas
(ins, outs) <- selectTxs txids
pure $ txHistoryFromEntity metas ins outs
@@ -137,7 +137,7 @@ import qualified Data.Set as Set
data Wallet s t where
Wallet :: (IsOurs s, NFData s, Show s, TxId t)
=> UTxO -- Unspent tx outputs belonging to this wallet
-> Set Tx -- Pending outgoing transactions
-> Set (Tx, TxMeta) -- Pending outgoing transactions
-> BlockHeader -- Header of the latest applied block (current tip)
-> s -- Address discovery state
-> Wallet s t
@@ -209,7 +209,7 @@ applyBlocks blocks cp0 =
let (txs', cp') = applyBlock b cp in (txs <> txs', cp')

newPending
:: Tx
:: (Tx, TxMeta)
-> Wallet s t
-> Wallet s t
newPending !tx (Wallet !u !pending !tip !s) =
@@ -224,7 +224,7 @@ unsafeInitWallet
:: (IsOurs s, NFData s, Show s, TxId t)
=> UTxO
-- ^ Unspent tx outputs belonging to this wallet
-> Set Tx
-> Set (Tx, TxMeta)
-- ^ Pending outgoing transactions
-> BlockHeader
-- ^ Header of the latest applied block (current tip)
@@ -258,19 +258,19 @@ totalBalance =
-- | Available UTxO = @pending ⋪ utxo@
availableUTxO :: Wallet s t -> UTxO
availableUTxO (Wallet u pending _ _) =
u `excluding` txIns pending
u `excluding` txIns (Set.map fst pending)

-- | Total UTxO = 'availableUTxO' @<>@ 'changeUTxO'
totalUTxO :: forall s t. Wallet s t -> UTxO
totalUTxO wallet@(Wallet _ pending _ s) =
availableUTxO wallet <> changeUTxO (Proxy @t) pending s
availableUTxO wallet <> changeUTxO (Proxy @t) (Set.map fst pending) s

-- | Actual utxo
utxo :: Wallet s t -> UTxO
utxo (Wallet u _ _ _) = u

-- | Get the set of pending transactions
getPending :: Wallet s t -> Set Tx
getPending :: Wallet s t -> Set (Tx, TxMeta)
getPending (Wallet _ pending _ _) = pending

{-------------------------------------------------------------------------------
@@ -377,9 +377,9 @@ utxoOurs _ tx = runState $ toUtxo <$> forM (zip [0..] (outputs tx)) filterOut

-- | Remove transactions from the pending set if their inputs appear in the
-- given set.
pendingExcluding :: Set Tx -> Set TxIn -> Set Tx
pendingExcluding :: Set (Tx, TxMeta) -> Set TxIn -> Set (Tx, TxMeta)
pendingExcluding txs discovered =
Set.filter isStillPending txs
where
isStillPending =
Set.null . Set.intersection discovered . Set.fromList . inputs
Set.null . Set.intersection discovered . Set.fromList . inputs . fst
@@ -59,15 +59,9 @@ import Cardano.Wallet.Primitive.AddressDerivation
import Cardano.Wallet.Primitive.AddressDiscovery
( SeqState (..) )
import Cardano.Wallet.Primitive.Model
( Wallet, currentTip, getPending, getState, unsafeInitWallet, utxo )
( Wallet )
import Cardano.Wallet.Primitive.Types
( Hash (..)
, Tx (..)
, TxMeta (..)
, WalletId (..)
, WalletMetadata (..)
, isPending
)
( Hash (..), Tx (..), TxMeta (..), WalletId (..), WalletMetadata (..) )
import Control.Foldl
( Fold (..) )
import Control.Monad.IO.Class
@@ -226,18 +220,7 @@ mPutCheckpoint wid wal m@(M cp metas txs pk)
| otherwise = (Left (NoSuchWallet wid), m)

mReadCheckpoint :: MWid -> MockOp (Maybe MWallet)
mReadCheckpoint wid m@(M cp _ txs _) =
(Right (withPendingTxs <$> Map.lookup wid cp), m)
where
pending = maybe
mempty
(Set.fromList . fmap fst . Map.elems . Map.filter isPending)
(Map.lookup wid txs)
withPendingTxs c = unsafeInitWallet
(utxo c)
(getPending c <> pending)
(currentTip c)
(getState c)
mReadCheckpoint wid m@(M cp _ _ _) = (Right (Map.lookup wid cp), m)

mPutWalletMeta :: MWid -> WalletMetadata -> MockOp ()
mPutWalletMeta wid meta m@(M cp metas txs pk)
@@ -355,7 +355,11 @@ instance Arbitrary GenTxHistory where
-- Ensure unique transaction IDs within a given batch of transactions to add
-- to the history.
arbitrary = GenTxHistory . Map.fromList <$> do
txs <- arbitrary
-- NOTE
-- We discard pending transaction from any 'GenTxHistory since,
-- inserting a pending transaction actually has an effect on the
-- checkpoint's pending transactions of a same wallet.
txs <- filter (not . isPending) <$> arbitrary
return $ (\(tx, meta) -> (mockTxId tx, (tx, meta))) <$> txs
where
mockTxId :: Tx -> Hash "Tx"
@@ -729,7 +733,7 @@ dbPropertyTests = do
readPrivateKey)
)
it "Tx History vs Checkpoint & Wallet Metadata & Private Key"
(property . discardPending (prop_isolation putTxHistoryF
(property . (prop_isolation putTxHistoryF
readCheckpoint
readWalletMeta
readPrivateKey)
@@ -768,19 +772,6 @@ dbPropertyTests = do
it "Private Key"
(checkCoverage . (prop_parallelPut putPrivateKey readPrivateKey
(length . lrp @Maybe)))
where
-- NOTE
-- For the isolation property, we discard pending transaction since
-- inserting a pending transaction actually has an effect on the
-- checkpoint's pending transactions of a same wallet.
discardPending
:: (db -> (k, GenTxHistory) -> Property)
-> db
-> (k, GenTxHistory)
-> Property
discardPending prop db (wid, GenTxHistory txs) =
let txs' = Map.filter (not . isPending) txs
in prop db (wid, GenTxHistory txs')

-- | Provide a DBLayer to a Spec that requires it. The database is initialised
-- once, and cleared with 'cleanDB' before each test.

0 comments on commit 378313f

Please sign in to comment.
You can’t perform that action at this time.