{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Cardano.Wallet.DB.Store.Wallets.Store
( mkStoreTxWalletsHistory
, DeltaTxWalletsHistory(..)
, mkStoreWalletsMeta ) where
import Prelude
import Cardano.Wallet.DB.Sqlite.Schema
( EntityField (TxMetaWalletId), TxMeta )
import Cardano.Wallet.DB.Store.Meta.Model
( DeltaTxMetaHistory (Manipulate), TxMetaHistory, mkTxMetaHistory )
import Cardano.Wallet.DB.Store.Meta.Store
( mkStoreMetaTransactions )
import Cardano.Wallet.DB.Store.Transactions.Model
( DeltaTxHistory (..), TxHistoryF (..), mkTxHistory )
import Cardano.Wallet.DB.Store.Transactions.Store
( mkStoreTransactions )
import Cardano.Wallet.DB.Store.Wallets.Model
( DeltaTxWalletsHistory (..), walletsLinkedTransactions )
import Control.Applicative
( liftA2 )
import Control.Exception
( SomeException )
import Control.Monad
( forM, forM_ )
import Control.Monad.Except
( ExceptT (ExceptT), runExceptT )
import Data.DBVar
( Store (..) )
import Data.DeltaMap
( DeltaMap (..) )
import Data.Generics.Internal.VL
( view )
import Data.List
( nub )
import Database.Persist.Sql
( SqlPersistT, deleteWhere, entityVal, selectList, (==.) )
import qualified Cardano.Wallet.DB.Store.Meta.Model as TxMetaStore
import qualified Cardano.Wallet.DB.Store.Transactions.Model as TxStore
import qualified Cardano.Wallet.Primitive.Types as W
import qualified Data.Map.Strict as Map
mkStoreWalletsMeta :: Store
(SqlPersistT IO)
(DeltaMap W.WalletId DeltaTxMetaHistory)
mkStoreWalletsMeta :: Store (SqlPersistT IO) (DeltaMap WalletId DeltaTxMetaHistory)
mkStoreWalletsMeta =
Store :: forall (m :: * -> *) da.
m (Either SomeException (Base da))
-> (Base da -> m ()) -> (Base da -> da -> m ()) -> Store m da
Store
{ loadS :: SqlPersistT
IO
(Either
SomeException (Base (DeltaMap WalletId DeltaTxMetaHistory)))
loadS = SqlPersistT IO (Either SomeException (Map WalletId TxMetaHistory))
SqlPersistT
IO
(Either
SomeException (Base (DeltaMap WalletId DeltaTxMetaHistory)))
load
, writeS :: Base (DeltaMap WalletId DeltaTxMetaHistory) -> SqlPersistT IO ()
writeS = Map WalletId TxMetaHistory -> SqlPersistT IO ()
Base (DeltaMap WalletId DeltaTxMetaHistory) -> SqlPersistT IO ()
write
, updateS :: Base (DeltaMap WalletId DeltaTxMetaHistory)
-> DeltaMap WalletId DeltaTxMetaHistory -> SqlPersistT IO ()
updateS = Base (DeltaMap WalletId DeltaTxMetaHistory)
-> DeltaMap WalletId DeltaTxMetaHistory -> SqlPersistT IO ()
forall p.
p -> DeltaMap WalletId DeltaTxMetaHistory -> SqlPersistT IO ()
update
}
where
write :: Map WalletId TxMetaHistory -> SqlPersistT IO ()
write Map WalletId TxMetaHistory
reset = [(WalletId, TxMetaHistory)]
-> ((WalletId, TxMetaHistory) -> SqlPersistT IO ())
-> SqlPersistT IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map WalletId TxMetaHistory -> [(WalletId, TxMetaHistory)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map WalletId TxMetaHistory
reset) (((WalletId, TxMetaHistory) -> SqlPersistT IO ())
-> SqlPersistT IO ())
-> ((WalletId, TxMetaHistory) -> SqlPersistT IO ())
-> SqlPersistT IO ()
forall a b. (a -> b) -> a -> b
$ \(WalletId
wid,TxMetaHistory
metas)
-> Store (SqlPersistT IO) DeltaTxMetaHistory
-> Base DeltaTxMetaHistory -> SqlPersistT IO ()
forall (m :: * -> *) da. Store m da -> Base da -> m ()
writeS (WalletId -> Store (SqlPersistT IO) DeltaTxMetaHistory
mkStoreMetaTransactions WalletId
wid) Base DeltaTxMetaHistory
TxMetaHistory
metas
update :: p -> DeltaMap WalletId DeltaTxMetaHistory -> SqlPersistT IO ()
update p
_ (Insert WalletId
wid Base DeltaTxMetaHistory
metas) =
Store (SqlPersistT IO) DeltaTxMetaHistory
-> Base DeltaTxMetaHistory -> SqlPersistT IO ()
forall (m :: * -> *) da. Store m da -> Base da -> m ()
writeS (WalletId -> Store (SqlPersistT IO) DeltaTxMetaHistory
mkStoreMetaTransactions WalletId
wid) Base DeltaTxMetaHistory
metas
update p
_ (Delete WalletId
wid) = do
[Filter TxMeta] -> SqlPersistT IO ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere [EntityField TxMeta WalletId
forall typ. (typ ~ WalletId) => EntityField TxMeta typ
TxMetaWalletId EntityField TxMeta WalletId -> WalletId -> Filter TxMeta
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. WalletId
wid ]
update p
_ (Adjust WalletId
wid DeltaTxMetaHistory
da) =
Store (SqlPersistT IO) DeltaTxMetaHistory
-> Base DeltaTxMetaHistory
-> DeltaTxMetaHistory
-> SqlPersistT IO ()
forall (m :: * -> *) da. Store m da -> Base da -> da -> m ()
updateS (WalletId -> Store (SqlPersistT IO) DeltaTxMetaHistory
mkStoreMetaTransactions WalletId
wid) Base DeltaTxMetaHistory
forall a. HasCallStack => a
undefined DeltaTxMetaHistory
da
load :: SqlPersistT
IO
(Either SomeException (Map.Map W.WalletId TxMetaHistory))
load :: SqlPersistT IO (Either SomeException (Map WalletId TxMetaHistory))
load = do
[WalletId]
wids <- [WalletId] -> [WalletId]
forall a. Eq a => [a] -> [a]
nub ([WalletId] -> [WalletId])
-> ([Entity TxMeta] -> [WalletId]) -> [Entity TxMeta] -> [WalletId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Entity TxMeta -> WalletId) -> [Entity TxMeta] -> [WalletId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((WalletId -> Const WalletId WalletId)
-> TxMeta -> Const WalletId TxMeta)
-> TxMeta -> WalletId
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
"txMetaWalletId"
((WalletId -> Const WalletId WalletId)
-> TxMeta -> Const WalletId TxMeta)
(WalletId -> Const WalletId WalletId)
-> TxMeta -> Const WalletId TxMeta
#txMetaWalletId (TxMeta -> WalletId)
-> (Entity TxMeta -> TxMeta) -> Entity TxMeta -> WalletId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity TxMeta -> TxMeta
forall record. Entity record -> record
entityVal)
([Entity TxMeta] -> [WalletId])
-> ReaderT SqlBackend IO [Entity TxMeta]
-> ReaderT SqlBackend IO [WalletId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Filter TxMeta]
-> [SelectOpt TxMeta] -> ReaderT SqlBackend IO [Entity TxMeta]
forall record backend (m :: * -> *).
(MonadIO m, PersistQueryRead backend,
PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m [Entity record]
selectList @TxMeta [] []
ExceptT SomeException (SqlPersistT IO) (Map WalletId TxMetaHistory)
-> SqlPersistT
IO (Either SomeException (Map WalletId TxMetaHistory))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT
SomeException (SqlPersistT IO) (Map WalletId TxMetaHistory)
-> SqlPersistT
IO (Either SomeException (Map WalletId TxMetaHistory)))
-> ExceptT
SomeException (SqlPersistT IO) (Map WalletId TxMetaHistory)
-> SqlPersistT
IO (Either SomeException (Map WalletId TxMetaHistory))
forall a b. (a -> b) -> a -> b
$ do
[TxMetaHistory]
xs <- [WalletId]
-> (WalletId
-> ExceptT SomeException (SqlPersistT IO) TxMetaHistory)
-> ExceptT SomeException (SqlPersistT IO) [TxMetaHistory]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [WalletId]
wids ((WalletId -> ExceptT SomeException (SqlPersistT IO) TxMetaHistory)
-> ExceptT SomeException (SqlPersistT IO) [TxMetaHistory])
-> (WalletId
-> ExceptT SomeException (SqlPersistT IO) TxMetaHistory)
-> ExceptT SomeException (SqlPersistT IO) [TxMetaHistory]
forall a b. (a -> b) -> a -> b
$ ReaderT SqlBackend IO (Either SomeException TxMetaHistory)
-> ExceptT SomeException (SqlPersistT IO) TxMetaHistory
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT SqlBackend IO (Either SomeException TxMetaHistory)
-> ExceptT SomeException (SqlPersistT IO) TxMetaHistory)
-> (WalletId
-> ReaderT SqlBackend IO (Either SomeException TxMetaHistory))
-> WalletId
-> ExceptT SomeException (SqlPersistT IO) TxMetaHistory
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Store (SqlPersistT IO) DeltaTxMetaHistory
-> ReaderT SqlBackend IO (Either SomeException TxMetaHistory)
forall (m :: * -> *) da.
Store m da -> m (Either SomeException (Base da))
loadS (Store (SqlPersistT IO) DeltaTxMetaHistory
-> ReaderT SqlBackend IO (Either SomeException TxMetaHistory))
-> (WalletId -> Store (SqlPersistT IO) DeltaTxMetaHistory)
-> WalletId
-> ReaderT SqlBackend IO (Either SomeException TxMetaHistory)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WalletId -> Store (SqlPersistT IO) DeltaTxMetaHistory
mkStoreMetaTransactions
Map WalletId TxMetaHistory
-> ExceptT
SomeException (SqlPersistT IO) (Map WalletId TxMetaHistory)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map WalletId TxMetaHistory
-> ExceptT
SomeException (SqlPersistT IO) (Map WalletId TxMetaHistory))
-> Map WalletId TxMetaHistory
-> ExceptT
SomeException (SqlPersistT IO) (Map WalletId TxMetaHistory)
forall a b. (a -> b) -> a -> b
$ [(WalletId, TxMetaHistory)] -> Map WalletId TxMetaHistory
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(WalletId, TxMetaHistory)] -> Map WalletId TxMetaHistory)
-> [(WalletId, TxMetaHistory)] -> Map WalletId TxMetaHistory
forall a b. (a -> b) -> a -> b
$ [WalletId] -> [TxMetaHistory] -> [(WalletId, TxMetaHistory)]
forall a b. [a] -> [b] -> [(a, b)]
zip [WalletId]
wids [TxMetaHistory]
xs
mkStoreTxWalletsHistory
:: Store (SqlPersistT IO) DeltaTxWalletsHistory
mkStoreTxWalletsHistory :: Store (SqlPersistT IO) DeltaTxWalletsHistory
mkStoreTxWalletsHistory =
Store :: forall (m :: * -> *) da.
m (Either SomeException (Base da))
-> (Base da -> m ()) -> (Base da -> da -> m ()) -> Store m da
Store
{ loadS :: SqlPersistT IO (Either SomeException (Base DeltaTxWalletsHistory))
loadS =
(TxHistory
-> Map WalletId TxMetaHistory
-> (TxHistory, Map WalletId TxMetaHistory))
-> Either SomeException TxHistory
-> Either SomeException (Map WalletId TxMetaHistory)
-> Either SomeException (TxHistory, Map WalletId TxMetaHistory)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (Either SomeException TxHistory
-> Either SomeException (Map WalletId TxMetaHistory)
-> Either SomeException (TxHistory, Map WalletId TxMetaHistory))
-> SqlPersistT IO (Either SomeException TxHistory)
-> SqlPersistT
IO
(Either SomeException (Map WalletId TxMetaHistory)
-> Either SomeException (TxHistory, Map WalletId TxMetaHistory))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Store (SqlPersistT IO) DeltaTxHistory
-> SqlPersistT IO (Either SomeException (Base DeltaTxHistory))
forall (m :: * -> *) da.
Store m da -> m (Either SomeException (Base da))
loadS Store (SqlPersistT IO) DeltaTxHistory
mkStoreTransactions SqlPersistT
IO
(Either SomeException (Map WalletId TxMetaHistory)
-> Either SomeException (TxHistory, Map WalletId TxMetaHistory))
-> SqlPersistT
IO (Either SomeException (Map WalletId TxMetaHistory))
-> SqlPersistT
IO (Either SomeException (TxHistory, Map WalletId TxMetaHistory))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Store (SqlPersistT IO) (DeltaMap WalletId DeltaTxMetaHistory)
-> SqlPersistT
IO
(Either
SomeException (Base (DeltaMap WalletId DeltaTxMetaHistory)))
forall (m :: * -> *) da.
Store m da -> m (Either SomeException (Base da))
loadS Store (SqlPersistT IO) (DeltaMap WalletId DeltaTxMetaHistory)
mkStoreWalletsMeta
, writeS :: Base DeltaTxWalletsHistory -> SqlPersistT IO ()
writeS = \(txHistory,txMetaHistory) -> do
Store (SqlPersistT IO) DeltaTxHistory
-> Base DeltaTxHistory -> SqlPersistT IO ()
forall (m :: * -> *) da. Store m da -> Base da -> m ()
writeS Store (SqlPersistT IO) DeltaTxHistory
mkStoreTransactions Base DeltaTxHistory
TxHistory
txHistory
Store (SqlPersistT IO) (DeltaMap WalletId DeltaTxMetaHistory)
-> Base (DeltaMap WalletId DeltaTxMetaHistory) -> SqlPersistT IO ()
forall (m :: * -> *) da. Store m da -> Base da -> m ()
writeS Store (SqlPersistT IO) (DeltaMap WalletId DeltaTxMetaHistory)
mkStoreWalletsMeta Map WalletId TxMetaHistory
Base (DeltaMap WalletId DeltaTxMetaHistory)
txMetaHistory
, updateS :: Base DeltaTxWalletsHistory
-> DeltaTxWalletsHistory -> SqlPersistT IO ()
updateS = \(txh@(TxHistoryF mtxh),mtxmh) -> \case
ExpandTxWalletsHistory WalletId
wid [(Tx, TxMeta)]
cs -> do
Store (SqlPersistT IO) DeltaTxHistory
-> Base DeltaTxHistory -> DeltaTxHistory -> SqlPersistT IO ()
forall (m :: * -> *) da. Store m da -> Base da -> da -> m ()
updateS Store (SqlPersistT IO) DeltaTxHistory
mkStoreTransactions Base DeltaTxHistory
TxHistory
txh
(DeltaTxHistory -> SqlPersistT IO ())
-> DeltaTxHistory -> SqlPersistT IO ()
forall a b. (a -> b) -> a -> b
$ TxHistory -> DeltaTxHistory
TxStore.Append
(TxHistory -> DeltaTxHistory) -> TxHistory -> DeltaTxHistory
forall a b. (a -> b) -> a -> b
$ [Tx] -> TxHistory
mkTxHistory
([Tx] -> TxHistory) -> [Tx] -> TxHistory
forall a b. (a -> b) -> a -> b
$ (Tx, TxMeta) -> Tx
forall a b. (a, b) -> a
fst ((Tx, TxMeta) -> Tx) -> [(Tx, TxMeta)] -> [Tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Tx, TxMeta)]
cs
Store (SqlPersistT IO) (DeltaMap WalletId DeltaTxMetaHistory)
-> Base (DeltaMap WalletId DeltaTxMetaHistory)
-> DeltaMap WalletId DeltaTxMetaHistory
-> SqlPersistT IO ()
forall (m :: * -> *) da. Store m da -> Base da -> da -> m ()
updateS Store (SqlPersistT IO) (DeltaMap WalletId DeltaTxMetaHistory)
mkStoreWalletsMeta Map WalletId TxMetaHistory
Base (DeltaMap WalletId DeltaTxMetaHistory)
mtxmh
(DeltaMap WalletId DeltaTxMetaHistory -> SqlPersistT IO ())
-> DeltaMap WalletId DeltaTxMetaHistory -> SqlPersistT IO ()
forall a b. (a -> b) -> a -> b
$ case WalletId -> Map WalletId TxMetaHistory -> Maybe TxMetaHistory
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup WalletId
wid Map WalletId TxMetaHistory
mtxmh of
Maybe TxMetaHistory
Nothing ->
WalletId
-> Base DeltaTxMetaHistory -> DeltaMap WalletId DeltaTxMetaHistory
forall key da. key -> Base da -> DeltaMap key da
Insert WalletId
wid (Base DeltaTxMetaHistory -> DeltaMap WalletId DeltaTxMetaHistory)
-> Base DeltaTxMetaHistory -> DeltaMap WalletId DeltaTxMetaHistory
forall a b. (a -> b) -> a -> b
$ WalletId -> [(Tx, TxMeta)] -> TxMetaHistory
mkTxMetaHistory WalletId
wid [(Tx, TxMeta)]
cs
Just TxMetaHistory
_ ->
WalletId
-> DeltaTxMetaHistory -> DeltaMap WalletId DeltaTxMetaHistory
forall key da. key -> da -> DeltaMap key da
Adjust WalletId
wid
(DeltaTxMetaHistory -> DeltaMap WalletId DeltaTxMetaHistory)
-> DeltaTxMetaHistory -> DeltaMap WalletId DeltaTxMetaHistory
forall a b. (a -> b) -> a -> b
$ TxMetaHistory -> DeltaTxMetaHistory
TxMetaStore.Expand
(TxMetaHistory -> DeltaTxMetaHistory)
-> TxMetaHistory -> DeltaTxMetaHistory
forall a b. (a -> b) -> a -> b
$ WalletId -> [(Tx, TxMeta)] -> TxMetaHistory
mkTxMetaHistory WalletId
wid [(Tx, TxMeta)]
cs
ChangeTxMetaWalletsHistory WalletId
wid ManipulateTxMetaHistory
change
-> Store (SqlPersistT IO) (DeltaMap WalletId DeltaTxMetaHistory)
-> Base (DeltaMap WalletId DeltaTxMetaHistory)
-> DeltaMap WalletId DeltaTxMetaHistory
-> SqlPersistT IO ()
forall (m :: * -> *) da. Store m da -> Base da -> da -> m ()
updateS Store (SqlPersistT IO) (DeltaMap WalletId DeltaTxMetaHistory)
mkStoreWalletsMeta Map WalletId TxMetaHistory
Base (DeltaMap WalletId DeltaTxMetaHistory)
mtxmh
(DeltaMap WalletId DeltaTxMetaHistory -> SqlPersistT IO ())
-> DeltaMap WalletId DeltaTxMetaHistory -> SqlPersistT IO ()
forall a b. (a -> b) -> a -> b
$ WalletId
-> DeltaTxMetaHistory -> DeltaMap WalletId DeltaTxMetaHistory
forall key da. key -> da -> DeltaMap key da
Adjust WalletId
wid
(DeltaTxMetaHistory -> DeltaMap WalletId DeltaTxMetaHistory)
-> DeltaTxMetaHistory -> DeltaMap WalletId DeltaTxMetaHistory
forall a b. (a -> b) -> a -> b
$ ManipulateTxMetaHistory -> DeltaTxMetaHistory
Manipulate ManipulateTxMetaHistory
change
DeltaTxWalletsHistory
GarbageCollectTxWalletsHistory -> (TxId -> SqlPersistT IO ()) -> [TxId] -> SqlPersistT IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
(Store (SqlPersistT IO) DeltaTxHistory
-> Base DeltaTxHistory -> DeltaTxHistory -> SqlPersistT IO ()
forall (m :: * -> *) da. Store m da -> Base da -> da -> m ()
updateS Store (SqlPersistT IO) DeltaTxHistory
mkStoreTransactions Base DeltaTxHistory
TxHistory
txh (DeltaTxHistory -> SqlPersistT IO ())
-> (TxId -> DeltaTxHistory) -> TxId -> SqlPersistT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxId -> DeltaTxHistory
DeleteTx)
([TxId] -> SqlPersistT IO ()) -> [TxId] -> SqlPersistT IO ()
forall a b. (a -> b) -> a -> b
$ Map TxId (TxRelationF 'Without) -> [TxId]
forall k a. Map k a -> [k]
Map.keys
(Map TxId (TxRelationF 'Without) -> [TxId])
-> Map TxId (TxRelationF 'Without) -> [TxId]
forall a b. (a -> b) -> a -> b
$ Map TxId (TxRelationF 'Without)
-> Set TxId -> Map TxId (TxRelationF 'Without)
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.withoutKeys Map TxId (TxRelationF 'Without)
mtxh
(Set TxId -> Map TxId (TxRelationF 'Without))
-> Set TxId -> Map TxId (TxRelationF 'Without)
forall a b. (a -> b) -> a -> b
$ Map WalletId TxMetaHistory -> Set TxId
walletsLinkedTransactions Map WalletId TxMetaHistory
mtxmh
RemoveWallet WalletId
wid -> Store (SqlPersistT IO) (DeltaMap WalletId DeltaTxMetaHistory)
-> Base (DeltaMap WalletId DeltaTxMetaHistory)
-> DeltaMap WalletId DeltaTxMetaHistory
-> SqlPersistT IO ()
forall (m :: * -> *) da. Store m da -> Base da -> da -> m ()
updateS Store (SqlPersistT IO) (DeltaMap WalletId DeltaTxMetaHistory)
mkStoreWalletsMeta Map WalletId TxMetaHistory
Base (DeltaMap WalletId DeltaTxMetaHistory)
mtxmh (DeltaMap WalletId DeltaTxMetaHistory -> SqlPersistT IO ())
-> DeltaMap WalletId DeltaTxMetaHistory -> SqlPersistT IO ()
forall a b. (a -> b) -> a -> b
$ WalletId -> DeltaMap WalletId DeltaTxMetaHistory
forall key da. key -> DeltaMap key da
Delete WalletId
wid
}