{-# LANGUAGE LambdaCase #-}

{- |
 Copyright: © 2018-2022 IOHK
 License: Apache-2.0

Low level 'Store' for a collection of meta-transactions,
i.e. additional data ('TxMeta') that the wallet stores for each transaction.
Meta-transactions are specific to a wallet.

-}
module Cardano.Wallet.DB.Store.Meta.Store ( mkStoreMetaTransactions ) where

import Prelude

import Cardano.Wallet.DB.Sqlite.Schema
    ( EntityField (..), TxMeta (..) )
import Cardano.Wallet.DB.Store.Meta.Model
    ( DeltaTxMetaHistory (..)
    , ManipulateTxMetaHistory (..)
    , TxMetaHistory (..)
    )
import Cardano.Wallet.Primitive.Types
    ( WalletId )
import Control.Arrow
    ( (&&&) )
import Control.Exception
    ( SomeException )
import Control.Monad
    ( void )
import Data.DBVar
    ( Store (Store, loadS, updateS, writeS) )
import Data.Foldable
    ( Foldable (toList) )
import Data.List.Split
    ( chunksOf )
import Data.Maybe
    ( fromJust )
import Database.Persist.Sql
    ( Entity (entityVal)
    , PersistEntity (keyFromRecordM)
    , PersistQueryRead (selectFirst)
    , SqlPersistT
    , deleteWhere
    , deleteWhereCount
    , repsertMany
    , selectList
    , updateWhere
    , (<-.)
    , (<=.)
    , (=.)
    , (==.)
    , (>.)
    )

import qualified Cardano.Wallet.Primitive.Types.Tx as W
import qualified Data.Map.Strict as Map

-- | Create an SQL store to hold meta transactions for a wallet.
mkStoreMetaTransactions :: WalletId
    -> Store (SqlPersistT IO) DeltaTxMetaHistory
mkStoreMetaTransactions :: WalletId -> Store (SqlPersistT IO) DeltaTxMetaHistory
mkStoreMetaTransactions
    WalletId
wid = 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 DeltaTxMetaHistory))
loadS = WalletId -> SqlPersistT IO (Either SomeException TxMetaHistory)
load WalletId
wid, writeS :: Base DeltaTxMetaHistory -> SqlPersistT IO ()
writeS = WalletId -> TxMetaHistory -> SqlPersistT IO ()
write WalletId
wid, updateS :: Base DeltaTxMetaHistory -> DeltaTxMetaHistory -> SqlPersistT IO ()
updateS = WalletId
-> TxMetaHistory -> DeltaTxMetaHistory -> SqlPersistT IO ()
update WalletId
wid }

update :: WalletId -> TxMetaHistory -> DeltaTxMetaHistory -> SqlPersistT IO ()
update :: WalletId
-> TxMetaHistory -> DeltaTxMetaHistory -> SqlPersistT IO ()
update WalletId
wid TxMetaHistory
_ DeltaTxMetaHistory
change = case DeltaTxMetaHistory
change of
    Expand TxMetaHistory
txs -> TxMetaHistory -> SqlPersistT IO ()
putMetas TxMetaHistory
txs
    Manipulate (PruneTxMetaHistory TxId
tid) -> do
        let filt :: [Filter TxMeta]
filt = [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, EntityField TxMeta TxId
forall typ. (typ ~ TxId) => EntityField TxMeta typ
TxMetaTxId EntityField TxMeta TxId -> TxId -> Filter TxMeta
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. TxId
tid]
        [Filter TxMeta]
-> [SelectOpt TxMeta]
-> ReaderT SqlBackend IO (Maybe (Entity TxMeta))
forall backend (m :: * -> *) record.
(PersistQueryRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m (Maybe (Entity record))
selectFirst ((EntityField TxMeta TxStatus
forall typ. (typ ~ TxStatus) => EntityField TxMeta typ
TxMetaStatus EntityField TxMeta TxStatus -> TxStatus -> Filter TxMeta
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. TxStatus
W.InLedger) Filter TxMeta -> [Filter TxMeta] -> [Filter TxMeta]
forall a. a -> [a] -> [a]
: [Filter TxMeta]
filt) [] ReaderT SqlBackend IO (Maybe (Entity TxMeta))
-> (Maybe (Entity TxMeta) -> SqlPersistT IO ())
-> SqlPersistT IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just Entity TxMeta
_ -> () -> SqlPersistT IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- marked in ledger - refuse to delete
            Maybe (Entity TxMeta)
Nothing -> ReaderT SqlBackend IO Int64 -> SqlPersistT IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
                (ReaderT SqlBackend IO Int64 -> SqlPersistT IO ())
-> ReaderT SqlBackend IO Int64 -> SqlPersistT IO ()
forall a b. (a -> b) -> a -> b
$ [Filter TxMeta] -> ReaderT SqlBackend IO Int64
forall val (m :: * -> *) backend.
(PersistEntity val, MonadIO m,
 PersistEntityBackend val ~ SqlBackend,
 BackendCompatible SqlBackend backend) =>
[Filter val] -> ReaderT backend m Int64
deleteWhereCount
                ([Filter TxMeta] -> ReaderT SqlBackend IO Int64)
-> [Filter TxMeta] -> ReaderT SqlBackend IO Int64
forall a b. (a -> b) -> a -> b
$ (EntityField TxMeta TxStatus
forall typ. (typ ~ TxStatus) => EntityField TxMeta typ
TxMetaStatus EntityField TxMeta TxStatus -> [TxStatus] -> Filter TxMeta
forall v typ.
PersistField typ =>
EntityField v typ -> [typ] -> Filter v
<-. [TxStatus
W.Pending, TxStatus
W.Expired]) Filter TxMeta -> [Filter TxMeta] -> [Filter TxMeta]
forall a. a -> [a] -> [a]
: [Filter TxMeta]
filt
    Manipulate (AgeTxMetaHistory SlotNo
tip) -> [Filter TxMeta] -> [Update TxMeta] -> SqlPersistT IO ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> [Update record] -> ReaderT backend m ()
updateWhere
        [ 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
        , EntityField TxMeta TxStatus
forall typ. (typ ~ TxStatus) => EntityField TxMeta typ
TxMetaStatus EntityField TxMeta TxStatus -> TxStatus -> Filter TxMeta
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. TxStatus
W.Pending
        , EntityField TxMeta (Maybe SlotNo)
forall typ. (typ ~ Maybe SlotNo) => EntityField TxMeta typ
TxMetaSlotExpires EntityField TxMeta (Maybe SlotNo) -> Maybe SlotNo -> Filter TxMeta
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
<=. SlotNo -> Maybe SlotNo
forall a. a -> Maybe a
Just SlotNo
tip
        ]
        [EntityField TxMeta TxStatus
forall typ. (typ ~ TxStatus) => EntityField TxMeta typ
TxMetaStatus EntityField TxMeta TxStatus -> TxStatus -> Update TxMeta
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. TxStatus
W.Expired]
    Manipulate (RollBackTxMetaHistory SlotNo
point) -> do
        let
          isAfter :: Filter TxMeta
isAfter = EntityField TxMeta SlotNo
forall typ. (typ ~ SlotNo) => EntityField TxMeta typ
TxMetaSlot EntityField TxMeta SlotNo -> SlotNo -> Filter TxMeta
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
>. SlotNo
point
          isIncoming :: Filter TxMeta
isIncoming = EntityField TxMeta Direction
forall typ. (typ ~ Direction) => EntityField TxMeta typ
TxMetaDirection EntityField TxMeta Direction -> Direction -> Filter TxMeta
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Direction
W.Incoming
          notIncoming :: Filter TxMeta
notIncoming = EntityField TxMeta Direction
forall typ. (typ ~ Direction) => EntityField TxMeta typ
TxMetaDirection EntityField TxMeta Direction -> Direction -> Filter TxMeta
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Direction
W.Outgoing
        [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
            , Filter TxMeta
isAfter, Filter TxMeta
isIncoming
            ]
        [Filter TxMeta] -> [Update TxMeta] -> SqlPersistT IO ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> [Update record] -> ReaderT backend m ()
updateWhere
            [ 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
            , Filter TxMeta
isAfter, Filter TxMeta
notIncoming
            ]
            [ EntityField TxMeta SlotNo
forall typ. (typ ~ SlotNo) => EntityField TxMeta typ
TxMetaSlot EntityField TxMeta SlotNo -> SlotNo -> Update TxMeta
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. SlotNo
point, EntityField TxMeta TxStatus
forall typ. (typ ~ TxStatus) => EntityField TxMeta typ
TxMetaStatus EntityField TxMeta TxStatus -> TxStatus -> Update TxMeta
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. TxStatus
W.Pending ]

write :: WalletId -> TxMetaHistory -> SqlPersistT IO ()
write :: WalletId -> TxMetaHistory -> SqlPersistT IO ()
write WalletId
wid TxMetaHistory
txs = 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]
    TxMetaHistory -> SqlPersistT IO ()
putMetas TxMetaHistory
txs

load :: WalletId
    -> SqlPersistT IO (Either SomeException TxMetaHistory)
load :: WalletId -> SqlPersistT IO (Either SomeException TxMetaHistory)
load WalletId
wid =
    TxMetaHistory -> Either SomeException TxMetaHistory
forall a b. b -> Either a b
Right
    (TxMetaHistory -> Either SomeException TxMetaHistory)
-> ([Entity TxMeta] -> TxMetaHistory)
-> [Entity TxMeta]
-> Either SomeException TxMetaHistory
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map TxId TxMeta -> TxMetaHistory
TxMetaHistory
    (Map TxId TxMeta -> TxMetaHistory)
-> ([Entity TxMeta] -> Map TxId TxMeta)
-> [Entity TxMeta]
-> TxMetaHistory
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(TxId, TxMeta)] -> Map TxId TxMeta
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    ([(TxId, TxMeta)] -> Map TxId TxMeta)
-> ([Entity TxMeta] -> [(TxId, TxMeta)])
-> [Entity TxMeta]
-> Map TxId TxMeta
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Entity TxMeta -> (TxId, TxMeta))
-> [Entity TxMeta] -> [(TxId, TxMeta)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((TxMeta -> TxId
txMetaTxId (TxMeta -> TxId) -> (TxMeta -> TxMeta) -> TxMeta -> (TxId, TxMeta)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& TxMeta -> TxMeta
forall a. a -> a
id) (TxMeta -> (TxId, TxMeta))
-> (Entity TxMeta -> TxMeta) -> Entity TxMeta -> (TxId, TxMeta)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity TxMeta -> TxMeta
forall record. Entity record -> record
entityVal)
    ([Entity TxMeta] -> Either SomeException TxMetaHistory)
-> ReaderT SqlBackend IO [Entity TxMeta]
-> SqlPersistT IO (Either SomeException TxMetaHistory)
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 [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] []

-- | Insert multiple meta-transactions, overwriting the previous version in
-- case of the same transaction index.
-- Only one meta-transaction can be stored per transaction for a given wallet.
putMetas :: TxMetaHistory -> SqlPersistT IO ()
putMetas :: TxMetaHistory -> SqlPersistT IO ()
putMetas (TxMetaHistory Map TxId TxMeta
metas) =
    ([(Key TxMeta, TxMeta)] -> SqlPersistT IO ())
-> [(Key TxMeta, TxMeta)] -> SqlPersistT IO ()
forall (m :: * -> *) e b. Monad m => ([e] -> m b) -> [e] -> m ()
chunked [(Key TxMeta, TxMeta)] -> SqlPersistT IO ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[(Key record, record)] -> ReaderT backend m ()
repsertMany [(Maybe (TxMeta -> Key TxMeta) -> TxMeta -> Key TxMeta
forall a. HasCallStack => Maybe a -> a
fromJust Maybe (TxMeta -> Key TxMeta)
forall record. PersistEntity record => Maybe (record -> Key record)
keyFromRecordM TxMeta
x, TxMeta
x) | TxMeta
x <- Map TxId TxMeta -> [TxMeta]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Map TxId TxMeta
metas]
    where
        -- needed to submit large numberot transactions
        chunked :: ([e] -> m b) -> [e] -> m ()
chunked [e] -> m b
f [e]
xs = ([e] -> m b) -> [[e]] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [e] -> m b
f (Int -> [e] -> [[e]]
forall e. Int -> [e] -> [[e]]
chunksOf Int
1000 [e]
xs)