diff --git a/lib/core/src/Cardano/Wallet/Api/Server.hs b/lib/core/src/Cardano/Wallet/Api/Server.hs index f3115b43139..e0b8395e464 100644 --- a/lib/core/src/Cardano/Wallet/Api/Server.hs +++ b/lib/core/src/Cardano/Wallet/Api/Server.hs @@ -2649,7 +2649,7 @@ decodeTransaction ctx (ApiT wid) (ApiSerialisedTransaction (ApiT sealed)) = do , metadata , scriptValidity }) = decodedTx - (txinsOutsPaths, collsOutsPaths, outsPath, acct, acctPath, pp, policyXPubM) + (txinsOutsPaths, collateralInsOutsPaths, outsPath, acct, acctPath, pp, policyXPubM) <- withWorkerCtx ctx wid liftE liftE $ \wrk -> do (acct, _, acctPath) <- liftHandler $ W.readRewardAccount @_ @s @k @n wrk wid @@ -2678,7 +2678,7 @@ decodeTransaction ctx (ApiT wid) (ApiSerialisedTransaction (ApiT sealed)) = do , fee = maybe (Quantity 0) (Quantity . fromIntegral . unCoin) fee , inputs = map toInp txinsOutsPaths , outputs = map toOut outsPath - , collateral = map toInp collsOutsPaths + , collateral = map toInp collateralInsOutsPaths -- TODO: [ADP-1670] , collateralOutputs = ApiAsArray Nothing , withdrawals = map (toWrdl acct) $ Map.assocs withdrawals diff --git a/lib/core/src/Cardano/Wallet/DB/Store/Transactions/Model.hs b/lib/core/src/Cardano/Wallet/DB/Store/Transactions/Model.hs index 2f2237da76e..7ff33bab485 100644 --- a/lib/core/src/Cardano/Wallet/DB/Store/Transactions/Model.hs +++ b/lib/core/src/Cardano/Wallet/DB/Store/Transactions/Model.hs @@ -13,7 +13,7 @@ {-# LANGUAGE UndecidableInstances #-} {- | -Copyright: © 2018-2022 IOHK +Copyright: © 2022 IOHK License: Apache-2.0 Data type 'TxHistory' for storing a set of transactions. @@ -28,7 +28,7 @@ module Cardano.Wallet.DB.Store.Transactions.Model , tokenCollateralOrd , tokenOutOrd , mkTxHistory - , TxRelationTxOutCtxK (..) + , TxRelationTxInContextK (..) ) where import Prelude @@ -78,20 +78,19 @@ import qualified Data.Map.Strict as Map -- | A context that carries a TxOut together with its tokens -- (this will be needed in the future for the DB Layer). -data WithTxOut a = - WithTxOut - { withTxOut_value :: a, withTxOut_context :: Maybe (TxOut, [TxOutToken]) } +data TxInContext txin = TxInContext + { txIn :: txin, context :: Maybe (TxOut, [TxOutToken]) } deriving ( Show, Eq, Functor ) -- | A kind to index the 2 flavours of a 'TxRelationF', with or without 'TxOuts' -data TxRelationTxOutCtxK - = NoTxOutCtx - | WithTxOutCtx +data TxRelationTxInContextK + = NoTxInContext + | WithTxInContext -- | Define the TxOut context type -type family TxRelationTxOutCtx f a where - TxRelationTxOutCtx 'NoTxOutCtx a = a - TxRelationTxOutCtx 'WithTxOutCtx a = WithTxOut a +type family TxRelationTxInContext f a where + TxRelationTxInContext 'NoTxInContext a = a + TxRelationTxInContext 'WithTxInContext a = TxInContext a {- | A low level definition of a transactions covering all transaction content by collecting all related-to-index database rows. @@ -101,35 +100,35 @@ type family TxRelationTxOutCtx f a where All values used here are records in the database: all foreign keys are used to group data correctly but they are not removed from the data. -} -data TxRelationF (f :: TxRelationTxOutCtxK) = +data TxRelationF (f :: TxRelationTxInContextK) = TxRelationF - { txRelation_ins :: [TxRelationTxOutCtx f TxIn] - , txRelation_colls :: [TxRelationTxOutCtx f TxCollateral] - , txRelation_outs :: [(TxOut, [TxOutToken])] - , txRelation_collouts :: Maybe (TxCollateralOut, [TxCollateralOutToken]) - , txRelation_withdraws :: [TxWithdrawal] + { ins :: [TxRelationTxInContext f TxIn] + , collateralIns :: [TxRelationTxInContext f TxCollateral] + , outs :: [(TxOut, [TxOutToken])] + , collateralOuts :: Maybe (TxCollateralOut, [TxCollateralOutToken]) + , withdrawals :: [TxWithdrawal] } deriving ( Generic ) -deriving instance ( Eq (TxRelationTxOutCtx f TxIn) - , Eq (TxRelationTxOutCtx f TxCollateral)) +deriving instance ( Eq (TxRelationTxInContext f TxIn) + , Eq (TxRelationTxInContext f TxCollateral)) => Eq (TxRelationF f) -deriving instance ( Show (TxRelationTxOutCtx f TxIn) - , Show (TxRelationTxOutCtx f TxCollateral)) +deriving instance ( Show (TxRelationTxInContext f TxIn) + , Show (TxRelationTxInContext f TxCollateral)) => Show (TxRelationF f) -- | Transactions history is 'TxRelationF's indexed by 'TxId' newtype TxHistoryF f = - TxHistoryF { txHistory_relations :: Map TxId (TxRelationF f) } + TxHistoryF { relations :: Map TxId (TxRelationF f) } deriving ( Generic ) -deriving instance ( Eq (TxRelationTxOutCtx f TxIn) - , Eq (TxRelationTxOutCtx f TxCollateral)) +deriving instance ( Eq (TxRelationTxInContext f TxIn) + , Eq (TxRelationTxInContext f TxCollateral)) => Eq (TxHistoryF f) -deriving instance ( Show (TxRelationTxOutCtx f TxIn) - , Show (TxRelationTxOutCtx f TxCollateral)) +deriving instance ( Show (TxRelationTxInContext f TxIn) + , Show (TxRelationTxInContext f TxCollateral)) => Show (TxHistoryF f) instance Monoid (TxHistoryF f) where @@ -139,18 +138,18 @@ instance Semigroup (TxHistoryF f) where TxHistoryF h1 <> TxHistoryF h2 = TxHistoryF $ Map.unionWith (error "clash") h1 h2 -instance ( Show (TxRelationTxOutCtx f TxIn) - , Show (TxRelationTxOutCtx f TxCollateral)) +instance ( Show (TxRelationTxInContext f TxIn) + , Show (TxRelationTxInContext f TxCollateral)) => Buildable (TxHistoryF f) where - build txs = "TxHistory " <> build (show $ txHistory_relations txs) + build txs = "TxHistory " <> build (show $ relations txs) -- | Shortcut type for history with tx without TxOut context -type TxHistory = TxHistoryF 'NoTxOutCtx +type TxHistory = TxHistoryF 'NoTxInContext -- | Verbs to change a 'TxHistory'. data DeltaTxHistory - = ExpandTxHistory TxHistory - | DeleteTxHistory TxId + = Expand TxHistory + | Delete TxId deriving ( Show, Eq, Generic ) instance Buildable DeltaTxHistory where @@ -158,8 +157,8 @@ instance Buildable DeltaTxHistory where instance Delta DeltaTxHistory where type Base DeltaTxHistory = TxHistory - apply (ExpandTxHistory txs) h = h <> txs - apply (DeleteTxHistory tid) (TxHistoryF txs) = + apply (Expand txs) h = h <> txs + apply (Delete tid) (TxHistoryF txs) = TxHistoryF $ Map.delete tid txs -- project high types to DB types @@ -256,15 +255,15 @@ mkTxWithdrawal tid (txWithdrawalAccount,txWithdrawalAmount) = where txWithdrawalTxId = tid -mkTxRelation :: W.Tx -> TxRelationF 'NoTxOutCtx +mkTxRelation :: W.Tx -> TxRelationF 'NoTxInContext mkTxRelation tx = TxRelationF - { txRelation_ins = fmap (mkTxIn tid) $ ordered . W.resolvedInputs $ tx - , txRelation_colls = + { ins = fmap (mkTxIn tid) $ ordered . W.resolvedInputs $ tx + , collateralIns = fmap (mkTxCollateral tid) $ ordered $ W.resolvedCollateralInputs tx - , txRelation_outs = fmap (mkTxOut tid) $ ordered $ W.outputs tx - , txRelation_collouts = mkTxCollateralOut tid <$> W.collateralOutput tx - , txRelation_withdraws = + , outs = fmap (mkTxOut tid) $ ordered $ W.outputs tx + , collateralOuts = mkTxCollateralOut tid <$> W.collateralOutput tx + , withdrawals = fmap (mkTxWithdrawal tid) $ Map.toList $ W.withdrawals tx } where diff --git a/lib/core/src/Cardano/Wallet/DB/Store/Transactions/Store.hs b/lib/core/src/Cardano/Wallet/DB/Store/Transactions/Store.hs index fd51183ad6b..8ef643bebc7 100644 --- a/lib/core/src/Cardano/Wallet/DB/Store/Transactions/Store.hs +++ b/lib/core/src/Cardano/Wallet/DB/Store/Transactions/Store.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -15,9 +16,7 @@ Implementation of a 'Store' for 'TxHistory'. module Cardano.Wallet.DB.Store.Transactions.Store ( selectTxHistory , putTxHistory - , mkStoreTransactions - ) - where + , mkStoreTransactions ) where import Prelude @@ -38,7 +37,7 @@ import Cardano.Wallet.DB.Store.Transactions.Model , TxHistory , TxHistoryF (TxHistoryF) , TxRelationF (..) - , TxRelationTxOutCtxK (NoTxOutCtx) + , TxRelationTxInContextK (NoTxInContext) , tokenCollateralOrd , tokenOutOrd ) @@ -72,19 +71,22 @@ mkStoreTransactions :: Store (SqlPersistT IO) DeltaTxHistory mkStoreTransactions = Store - { loadS = Right <$> selectTxHistory, writeS = write, updateS = update } + { loadS = Right <$> selectTxHistory + , writeS = write + , updateS = update + } update :: TxHistory -> DeltaTxHistory -> SqlPersistT IO () update _ change = case change of - ExpandTxHistory txs -> putTxHistory txs - DeleteTxHistory tid -> do - deleteWhere [TxInputTxId ==. tid] - deleteWhere [TxCollateralTxId ==. tid] - deleteWhere [TxOutTokenTxId ==. tid] - deleteWhere [TxOutputTxId ==. tid] - deleteWhere [TxCollateralOutTokenTxId ==. tid] - deleteWhere [TxCollateralOutTxId ==. tid] - deleteWhere [TxWithdrawalTxId ==. tid] + Expand txs -> putTxHistory txs + Delete tid -> do + deleteWhere [TxInputTxId ==. tid ] + deleteWhere [TxCollateralTxId ==. tid ] + deleteWhere [TxOutTokenTxId ==. tid ] + deleteWhere [TxOutputTxId ==. tid ] + deleteWhere [TxCollateralOutTokenTxId ==. tid ] + deleteWhere [TxCollateralOutTxId ==. tid ] + deleteWhere [TxWithdrawalTxId ==. tid ] write :: TxHistory -> SqlPersistT IO () write txs = do @@ -100,38 +102,40 @@ write txs = do -- | Insert multiple transactions putTxHistory :: TxHistory -> SqlPersistT IO () putTxHistory (TxHistoryF tx_map) = forM_ tx_map $ \TxRelationF {..} -> do - insertMany_ txRelation_ins - insertMany_ txRelation_colls - insertMany_ $ fst <$> txRelation_outs - insertMany_ $ txRelation_outs >>= snd - insertMany_ $ maybeToList $ fst <$> txRelation_collouts - insertMany_ $ maybeToList (txRelation_collouts) >>= snd - insertMany_ txRelation_withdraws + insertMany_ ins + insertMany_ collateralIns + insertMany_ $ fst <$> outs + insertMany_ $ outs >>= snd + insertMany_ $ maybeToList $ fst <$> collateralOuts + insertMany_ $ maybeToList (collateralOuts) >>= snd + insertMany_ withdrawals + + -- | Select transactions history from the database selectTxHistory :: SqlPersistT IO TxHistory selectTxHistory = TxHistoryF <$> select where - select :: SqlPersistT IO (Map TxId (TxRelationF 'NoTxOutCtx)) + selectListAll = selectList [] [] + select :: SqlPersistT IO (Map TxId (TxRelationF 'NoTxInContext)) select = do - inputs <- mkMap txInputTxId $ selectList [] [] - collaterals <- mkMap txCollateralTxId $ selectList [] [] - outputs <- mkMap txOutputTxId $ selectList [] [] - collateralOutputs <- fmap (fmap getFirst) - $ mkMap txCollateralOutTxId - $ selectList [] [] - withdrawals <- mkMap txWithdrawalTxId $ selectList [] [] - outTokens <- mkMap txOutTokenTxId $ selectList [] [] - collateralTokens <- mkMap txCollateralOutTokenTxId $ selectList [] [] + inputs <- mkMap txInputTxId selectListAll + collaterals <- mkMap txCollateralTxId selectListAll + outputs <- mkMap txOutputTxId selectListAll + collateralOutputs + <- fmap getFirst <$> mkMap txCollateralOutTxId selectListAll + withdrawals <- mkMap txWithdrawalTxId selectListAll + outTokens <- mkMap txOutTokenTxId selectListAll + collateralTokens <- mkMap txCollateralOutTokenTxId selectListAll let ids = fold - [ Map.keysSet inputs - , Map.keysSet collaterals - , Map.keysSet outputs - , Map.keysSet collateralOutputs - , Map.keysSet withdrawals - , Map.keysSet outTokens - , Map.keysSet collateralTokens + [Map.keysSet inputs + , Map.keysSet collaterals + , Map.keysSet outputs + , Map.keysSet collateralOutputs + , Map.keysSet withdrawals + , Map.keysSet outTokens + , Map.keysSet collateralTokens ] selectOutTokens :: TxId -> TxOut -> [TxOutToken] selectOutTokens txId txOut = @@ -147,23 +151,21 @@ selectTxHistory = TxHistoryF <$> select pure $ Map.singleton k $ TxRelationF - { txRelation_ins = - sortOn txInputOrder $ Map.findWithDefault [] k inputs - , txRelation_colls = sortOn txCollateralOrder + { ins = sortOn txInputOrder $ Map.findWithDefault [] k inputs + , collateralIns = sortOn txCollateralOrder $ Map.findWithDefault [] k collaterals - , txRelation_outs = fmap (fmap $ sortOn tokenOutOrd) + , outs = fmap (fmap $ sortOn tokenOutOrd) $ sortOn (txOutputIndex . fst) $ (id &&& selectOutTokens k) <$> Map.findWithDefault [] k outputs - , txRelation_collouts = fmap (fmap $ sortOn tokenCollateralOrd) + , collateralOuts = fmap (fmap $ sortOn tokenCollateralOrd) $ (id &&& selectCollateralTokens k) <$> Map.findWithDefault Nothing k collateralOutputs - , txRelation_withdraws = sortOn txWithdrawalAccount + , withdrawals = sortOn txWithdrawalAccount $ Map.findWithDefault [] k withdrawals } -mkMap - :: (Ord k, Functor f, Applicative g, Semigroup (g b)) +mkMap :: (Ord k, Functor f, Applicative g, Semigroup (g b)) => (b -> k) -> f [Entity b] -> f (Map k (g b)) diff --git a/lib/core/test/unit/Cardano/Wallet/DB/Store/Transactions/StoreSpec.hs b/lib/core/test/unit/Cardano/Wallet/DB/Store/Transactions/StoreSpec.hs index 54db55bbc91..00663f7df36 100644 --- a/lib/core/test/unit/Cardano/Wallet/DB/Store/Transactions/StoreSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/DB/Store/Transactions/StoreSpec.hs @@ -47,9 +47,9 @@ prop_StoreMetaLaws = withStoreProp $ \runQ -> genDeltas :: GenDelta DeltaTxHistory genDeltas (TxHistoryF history) = frequency - [ (8, ExpandTxHistory . mkTxHistory <$> arbitrary) - , (1, DeleteTxHistory . TxId <$> arbitrary) - , (2, DeleteTxHistory + [ (8, Expand . mkTxHistory <$> arbitrary) + , (1, Delete . TxId <$> arbitrary) + , (2, Delete <$> if null history then TxId <$> arbitrary else elements (Map.keys history)