{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- Copyright: © 2018-2020 IOHK
-- License: Apache-2.0
--
-- An implementation of the DBLayer which uses Persistent and SQLite.

module Cardano.Wallet.DB.Layer
    ( -- * Directory of single-file wallet databases
      newDBFactory
    , findDatabases
    , DBFactoryLog (..)

    -- * Internal implementation
    , withDBLayer
    , withDBLayerInMemory
    , WalletDBLog (..)
    , CacheBehavior (..)

    -- * Unbracketed internal implementation
    , newDBLayerWith
    , newDBLayerInMemory

    -- * Interfaces
    , PersistAddressBook (..)

    -- * Migration Support
    , DefaultFieldValues (..)

    ) where

import Prelude

import Cardano.Address.Derivation
    ( XPrv )
import Cardano.BM.Data.Severity
    ( Severity (..) )
import Cardano.BM.Data.Tracer
    ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) )
import Cardano.DB.Sqlite
    ( DBLog (..)
    , ForeignKeysSetting (ForeignKeysEnabled)
    , SqliteContext (..)
    , handleConstraint
    , newInMemorySqliteContext
    , newSqliteContext
    , withConnectionPool
    )
import Cardano.DB.Sqlite.Delete
    ( DeleteSqliteDatabaseLog
    , deleteSqliteDatabase
    , newRefCount
    , waitForFree
    , withRef
    )
import Cardano.Wallet.Checkpoints
    ( DeltaCheckpoints (..)
    , defaultSparseCheckpointsConfig
    , sparseCheckpoints
    )
import Cardano.Wallet.DB
    ( DBFactory (..)
    , DBLayer (..)
    , ErrNoSuchTransaction (..)
    , ErrPutLocalTxSubmission (..)
    , ErrRemoveTx (..)
    , ErrWalletAlreadyExists (..)
    )
import Cardano.Wallet.DB.Sqlite.Migration
    ( DefaultFieldValues (..), migrateManually )
import Cardano.Wallet.DB.Sqlite.Schema
    ( DelegationCertificate (..)
    , DelegationReward (..)
    , EntityField (..)
    , Key (..)
    , LocalTxSubmission (..)
    , PrivateKey (..)
    , StakeKeyCertificate (..)
    , TxMeta (..)
    , TxWithdrawal (txWithdrawalAmount)
    , Wallet (..)
    , migrateAll
    , unWalletKey
    )
import Cardano.Wallet.DB.Sqlite.Types
    ( BlockId (..), TxId (..) )
import Cardano.Wallet.DB.Store.Checkpoints
    ( PersistAddressBook (..), blockHeaderFromEntity, mkStoreWallets )
import Cardano.Wallet.DB.Store.Meta.Model
    ( ManipulateTxMetaHistory (..), TxMetaHistory (..) )
import Cardano.Wallet.DB.Store.Transactions.Model
    ( TxHistoryF (..), decorateWithTxOuts, withdrawals )
import Cardano.Wallet.DB.Store.Wallets.Model
    ( TxWalletsHistory, mkTransactionInfo )
import Cardano.Wallet.DB.Store.Wallets.Store
    ( DeltaTxWalletsHistory (..), mkStoreTxWalletsHistory )
import Cardano.Wallet.DB.WalletState
    ( DeltaMap (..)
    , DeltaWalletState1 (..)
    , ErrNoSuchWallet (..)
    , findNearestPoint
    , fromGenesis
    , fromWallet
    , getBlockHeight
    , getLatest
    , getSlot
    )
import Cardano.Wallet.Primitive.AddressDerivation
    ( Depth (..), PersistPrivateKey (..), WalletKey (..) )
import Cardano.Wallet.Primitive.Passphrase
    ( PassphraseHash )
import Cardano.Wallet.Primitive.Slotting
    ( TimeInterpreter, epochOf, firstSlotInEpoch, interpretQuery )
import Cardano.Wallet.Primitive.Types.Tx
    ( TransactionInfo (..), TxMeta (..) )
import Control.Exception
    ( throw )
import Control.Monad
    ( forM, guard, unless, void, when, (<=<) )
import Control.Monad.IO.Class
    ( MonadIO (..) )
import Control.Monad.Trans
    ( lift )
import Control.Monad.Trans.Except
    ( ExceptT (..) )
import Control.Tracer
    ( Tracer, contramap, traceWith )
import Data.Coerce
    ( coerce )
import Data.DBVar
    ( loadDBVar, modifyDBMaybe, readDBVar, updateDBVar )
import Data.Either
    ( isRight )
import Data.Foldable
    ( toList )
import Data.Generics.Internal.VL.Lens
    ( view, (^.) )
import Data.List
    ( sortOn )
import Data.Maybe
    ( catMaybes, fromMaybe, listToMaybe, maybeToList )
import Data.Ord
    ( Down (..) )
import Data.Proxy
    ( Proxy (..) )
import Data.Quantity
    ( Quantity (..) )
import Data.Text
    ( Text )
import Data.Text.Class
    ( ToText (..), fromText )
import Data.Word
    ( Word32 )
import Database.Persist.Class
    ( toPersistValue )
import Database.Persist.Sql
    ( Entity (..)
    , Filter
    , SelectOpt (..)
    , Single (..)
    , Update (..)
    , deleteWhere
    , insert_
    , rawExecute
    , rawSql
    , repsert
    , selectFirst
    , selectKeysList
    , selectList
    , updateWhere
    , upsert
    , (<.)
    , (=.)
    , (==.)
    , (>.)
    , (>=.)
    )
import Database.Persist.Sqlite
    ( SqlPersistT )
import Fmt
    ( pretty, (+|), (|+) )
import GHC.Generics
    ( Generic )
import System.Directory
    ( doesFileExist, listDirectory )
import System.FilePath
    ( (</>) )
import UnliftIO.Exception
    ( Exception, bracket, throwIO )
import UnliftIO.MVar
    ( modifyMVar, modifyMVar_, newMVar, readMVar, withMVar )

import qualified Cardano.Wallet.DB.Sqlite.Schema as DB
import qualified Cardano.Wallet.Primitive.Model as W
import qualified Cardano.Wallet.Primitive.Passphrase as W
import qualified Cardano.Wallet.Primitive.Types as W
import qualified Cardano.Wallet.Primitive.Types.Coin as Coin
import qualified Cardano.Wallet.Primitive.Types.Coin as W
import qualified Cardano.Wallet.Primitive.Types.Hash as W
import qualified Cardano.Wallet.Primitive.Types.Tx as W
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as T

{-------------------------------------------------------------------------------
                               Database "factory"
             (a directory containing one database file per wallet)
-------------------------------------------------------------------------------}

-- | Instantiate a 'DBFactory' from a given directory, or in-memory for testing.
newDBFactory
    :: forall s k.
        ( PersistAddressBook s
        , PersistPrivateKey (k 'RootK)
        , WalletKey k
        )
    => Tracer IO DBFactoryLog
       -- ^ Logging object
    -> DefaultFieldValues
       -- ^ Default database field values, used during migration.
    -> TimeInterpreter IO
       -- ^ Time interpreter for slot to time conversions
    -> Maybe FilePath
       -- ^ Path to database directory, or Nothing for in-memory database
    -> IO (DBFactory IO s k)
newDBFactory :: Tracer IO DBFactoryLog
-> DefaultFieldValues
-> TimeInterpreter IO
-> Maybe FilePath
-> IO (DBFactory IO s k)
newDBFactory Tracer IO DBFactoryLog
tr DefaultFieldValues
defaultFieldValues TimeInterpreter IO
ti = \case
    Maybe FilePath
Nothing -> do
        -- NOTE1
        -- For the in-memory database, we do actually preserve the database
        -- after the 'action' is done. This allows for calling 'withDatabase'
        -- several times within the same execution and get back the same
        -- database. The memory is only cleaned up when calling
        -- 'removeDatabase', to mimic the way the file database works!
        --
        -- NOTE2
        -- The in-memory withDatabase will leak memory unless removeDatabase is
        -- called after using the database. In practice, this is only a problem
        -- for testing.
        MVar (Map WalletId (DBLayer IO s k))
mvar <- Map WalletId (DBLayer IO s k)
-> IO (MVar (Map WalletId (DBLayer IO s k)))
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar Map WalletId (DBLayer IO s k)
forall a. Monoid a => a
mempty
        DBFactory IO s k -> IO (DBFactory IO s k)
forall (f :: * -> *) a. Applicative f => a -> f a
pure DBFactory :: forall (m :: * -> *) s (k :: Depth -> * -> *).
(forall a. WalletId -> (DBLayer m s k -> IO a) -> IO a)
-> (WalletId -> IO ()) -> IO [WalletId] -> DBFactory m s k
DBFactory
            { withDatabase :: forall a. WalletId -> (DBLayer IO s k -> IO a) -> IO a
withDatabase = \WalletId
wid DBLayer IO s k -> IO a
action -> do
                DBLayer IO s k
db <- MVar (Map WalletId (DBLayer IO s k))
-> (Map WalletId (DBLayer IO s k)
    -> IO (Map WalletId (DBLayer IO s k), DBLayer IO s k))
-> IO (DBLayer IO s k)
forall (m :: * -> *) a b.
MonadUnliftIO m =>
MVar a -> (a -> m (a, b)) -> m b
modifyMVar MVar (Map WalletId (DBLayer IO s k))
mvar ((Map WalletId (DBLayer IO s k)
  -> IO (Map WalletId (DBLayer IO s k), DBLayer IO s k))
 -> IO (DBLayer IO s k))
-> (Map WalletId (DBLayer IO s k)
    -> IO (Map WalletId (DBLayer IO s k), DBLayer IO s k))
-> IO (DBLayer IO s k)
forall a b. (a -> b) -> a -> b
$ \Map WalletId (DBLayer IO s k)
m -> case WalletId -> Map WalletId (DBLayer IO s k) -> Maybe (DBLayer IO s k)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup WalletId
wid Map WalletId (DBLayer IO s k)
m of
                    Just DBLayer IO s k
db -> (Map WalletId (DBLayer IO s k), DBLayer IO s k)
-> IO (Map WalletId (DBLayer IO s k), DBLayer IO s k)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map WalletId (DBLayer IO s k)
m, DBLayer IO s k
db)
                    Maybe (DBLayer IO s k)
Nothing -> do
                        let tr' :: Tracer IO WalletDBLog
tr' = (WalletDBLog -> DBFactoryLog)
-> Tracer IO DBFactoryLog -> Tracer IO WalletDBLog
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (FilePath -> WalletDBLog -> DBFactoryLog
MsgWalletDB FilePath
"") Tracer IO DBFactoryLog
tr
                        (IO ()
_cleanup, DBLayer IO s k
db) <- Tracer IO WalletDBLog
-> TimeInterpreter IO -> IO (IO (), DBLayer IO s k)
forall s (k :: Depth -> * -> *).
(PersistAddressBook s, PersistPrivateKey (k 'RootK)) =>
Tracer IO WalletDBLog
-> TimeInterpreter IO -> IO (IO (), DBLayer IO s k)
newDBLayerInMemory Tracer IO WalletDBLog
tr' TimeInterpreter IO
ti
                        (Map WalletId (DBLayer IO s k), DBLayer IO s k)
-> IO (Map WalletId (DBLayer IO s k), DBLayer IO s k)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WalletId
-> DBLayer IO s k
-> Map WalletId (DBLayer IO s k)
-> Map WalletId (DBLayer IO s k)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert WalletId
wid DBLayer IO s k
db Map WalletId (DBLayer IO s k)
m, DBLayer IO s k
db)
                DBLayer IO s k -> IO a
action DBLayer IO s k
db
            , removeDatabase :: WalletId -> IO ()
removeDatabase = \WalletId
wid -> do
                Tracer IO DBFactoryLog -> DBFactoryLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO DBFactoryLog
tr (DBFactoryLog -> IO ()) -> DBFactoryLog -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> DBFactoryLog
MsgRemoving (WalletId -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty WalletId
wid)
                MVar (Map WalletId (DBLayer IO s k))
-> (Map WalletId (DBLayer IO s k)
    -> IO (Map WalletId (DBLayer IO s k)))
-> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
MVar a -> (a -> m a) -> m ()
modifyMVar_ MVar (Map WalletId (DBLayer IO s k))
mvar (Map WalletId (DBLayer IO s k) -> IO (Map WalletId (DBLayer IO s k))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map WalletId (DBLayer IO s k)
 -> IO (Map WalletId (DBLayer IO s k)))
-> (Map WalletId (DBLayer IO s k) -> Map WalletId (DBLayer IO s k))
-> Map WalletId (DBLayer IO s k)
-> IO (Map WalletId (DBLayer IO s k))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WalletId
-> Map WalletId (DBLayer IO s k) -> Map WalletId (DBLayer IO s k)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete WalletId
wid)

            , listDatabases :: IO [WalletId]
listDatabases =
                Map WalletId (DBLayer IO s k) -> [WalletId]
forall k a. Map k a -> [k]
Map.keys (Map WalletId (DBLayer IO s k) -> [WalletId])
-> IO (Map WalletId (DBLayer IO s k)) -> IO [WalletId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar (Map WalletId (DBLayer IO s k))
-> IO (Map WalletId (DBLayer IO s k))
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar MVar (Map WalletId (DBLayer IO s k))
mvar
            }

    Just FilePath
databaseDir -> do
        RefCount WalletId
refs <- IO (RefCount WalletId)
forall ix. Ord ix => IO (RefCount ix)
newRefCount
        DBFactory IO s k -> IO (DBFactory IO s k)
forall (f :: * -> *) a. Applicative f => a -> f a
pure DBFactory :: forall (m :: * -> *) s (k :: Depth -> * -> *).
(forall a. WalletId -> (DBLayer m s k -> IO a) -> IO a)
-> (WalletId -> IO ()) -> IO [WalletId] -> DBFactory m s k
DBFactory
            { withDatabase :: forall a. WalletId -> (DBLayer IO s k -> IO a) -> IO a
withDatabase = \WalletId
wid DBLayer IO s k -> IO a
action -> RefCount WalletId -> WalletId -> IO a -> IO a
forall ix a. Ord ix => RefCount ix -> ix -> IO a -> IO a
withRef RefCount WalletId
refs WalletId
wid (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ Tracer IO WalletDBLog
-> DefaultFieldValues
-> FilePath
-> TimeInterpreter IO
-> (DBLayer IO s k -> IO a)
-> IO a
forall s (k :: Depth -> * -> *) a.
(PersistAddressBook s, PersistPrivateKey (k 'RootK),
 WalletKey k) =>
Tracer IO WalletDBLog
-> DefaultFieldValues
-> FilePath
-> TimeInterpreter IO
-> (DBLayer IO s k -> IO a)
-> IO a
withDBLayer
                ((WalletDBLog -> DBFactoryLog)
-> Tracer IO DBFactoryLog -> Tracer IO WalletDBLog
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (FilePath -> WalletDBLog -> DBFactoryLog
MsgWalletDB (WalletId -> FilePath
forall a. ToText a => a -> FilePath
databaseFile WalletId
wid)) Tracer IO DBFactoryLog
tr)
                DefaultFieldValues
defaultFieldValues
                (WalletId -> FilePath
forall a. ToText a => a -> FilePath
databaseFile WalletId
wid)
                TimeInterpreter IO
ti
                DBLayer IO s k -> IO a
action
            , removeDatabase :: WalletId -> IO ()
removeDatabase = \WalletId
wid -> do
                let widp :: Text
widp = WalletId -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty WalletId
wid
                -- try to wait for all 'withDatabase' calls to finish before
                -- deleting database file.
                let trWait :: Tracer IO (Maybe Int)
trWait = (Maybe Int -> DBFactoryLog)
-> Tracer IO DBFactoryLog -> Tracer IO (Maybe Int)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (Text -> Maybe Int -> DBFactoryLog
MsgWaitingForDatabase Text
widp) Tracer IO DBFactoryLog
tr
                -- TODO: rather than refcounting, why not keep retrying the
                -- delete until there are no file busy errors?
                Tracer IO (Maybe Int)
-> RefCount WalletId -> WalletId -> (Int -> IO ()) -> IO ()
forall ix a.
Ord ix =>
Tracer IO (Maybe Int) -> RefCount ix -> ix -> (Int -> IO a) -> IO a
waitForFree Tracer IO (Maybe Int)
trWait RefCount WalletId
refs WalletId
wid ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
inUse -> do
                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
inUse Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                        Tracer IO DBFactoryLog -> DBFactoryLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO DBFactoryLog
tr (DBFactoryLog -> IO ()) -> DBFactoryLog -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Int -> DBFactoryLog
MsgRemovingInUse Text
widp Int
inUse
                    Tracer IO DBFactoryLog -> DBFactoryLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO DBFactoryLog
tr (DBFactoryLog -> IO ()) -> DBFactoryLog -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> DBFactoryLog
MsgRemoving Text
widp
                    let trDel :: Tracer IO DeleteSqliteDatabaseLog
trDel = (DeleteSqliteDatabaseLog -> DBFactoryLog)
-> Tracer IO DBFactoryLog -> Tracer IO DeleteSqliteDatabaseLog
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (Text -> DeleteSqliteDatabaseLog -> DBFactoryLog
MsgRemovingDatabaseFile Text
widp) Tracer IO DBFactoryLog
tr
                    Tracer IO DeleteSqliteDatabaseLog -> FilePath -> IO ()
deleteSqliteDatabase Tracer IO DeleteSqliteDatabaseLog
trDel (WalletId -> FilePath
forall a. ToText a => a -> FilePath
databaseFile WalletId
wid)
            , listDatabases :: IO [WalletId]
listDatabases =
                Tracer IO DBFactoryLog -> FilePath -> IO [WalletId]
forall (k :: Depth -> * -> *).
WalletKey k =>
Tracer IO DBFactoryLog -> FilePath -> IO [WalletId]
findDatabases @k Tracer IO DBFactoryLog
tr FilePath
databaseDir
            }
      where
        databaseFilePrefix :: FilePath
databaseFilePrefix = Proxy k -> FilePath
forall (key :: Depth -> * -> *).
WalletKey key =>
Proxy key -> FilePath
keyTypeDescriptor (Proxy k -> FilePath) -> Proxy k -> FilePath
forall a b. (a -> b) -> a -> b
$ Proxy k
forall k (t :: k). Proxy t
Proxy @k
        databaseFile :: a -> FilePath
databaseFile a
wid =
            FilePath
databaseDir FilePath -> FilePath -> FilePath
</>
            FilePath
databaseFilePrefix FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"." FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<>
            Text -> FilePath
T.unpack (a -> Text
forall a. ToText a => a -> Text
toText a
wid) FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
".sqlite"

-- | Return all wallet databases that match the specified key type within the
--   specified directory.
findDatabases
    :: forall k. WalletKey k
    => Tracer IO DBFactoryLog
    -> FilePath
    -> IO [W.WalletId]
findDatabases :: Tracer IO DBFactoryLog -> FilePath -> IO [WalletId]
findDatabases Tracer IO DBFactoryLog
tr FilePath
dir = do
    [FilePath]
files <- FilePath -> IO [FilePath]
listDirectory FilePath
dir
    ([Maybe WalletId] -> [WalletId])
-> IO [Maybe WalletId] -> IO [WalletId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe WalletId] -> [WalletId]
forall a. [Maybe a] -> [a]
catMaybes (IO [Maybe WalletId] -> IO [WalletId])
-> IO [Maybe WalletId] -> IO [WalletId]
forall a b. (a -> b) -> a -> b
$ [FilePath]
-> (FilePath -> IO (Maybe WalletId)) -> IO [Maybe WalletId]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [FilePath]
files ((FilePath -> IO (Maybe WalletId)) -> IO [Maybe WalletId])
-> (FilePath -> IO (Maybe WalletId)) -> IO [Maybe WalletId]
forall a b. (a -> b) -> a -> b
$ \FilePath
file -> do
        Bool
isFile <- FilePath -> IO Bool
doesFileExist (FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
file)
        case (Bool
isFile, Text -> Text -> [Text]
T.splitOn Text
"." (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
file) of
            (Bool
True, Text
prefix : Text
basename : [Text
"sqlite"]) | Text
prefix Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
expectedPrefix ->
                case Text -> Either TextDecodingError WalletId
forall a. FromText a => Text -> Either TextDecodingError a
fromText Text
basename of
                    Right WalletId
wid -> do
                        Tracer IO DBFactoryLog -> DBFactoryLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO DBFactoryLog
tr (DBFactoryLog -> IO ()) -> DBFactoryLog -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Text -> DBFactoryLog
MsgFoundDatabase (FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
file) (WalletId -> Text
forall a. ToText a => a -> Text
toText WalletId
wid)
                        Maybe WalletId -> IO (Maybe WalletId)
forall (m :: * -> *) a. Monad m => a -> m a
return (WalletId -> Maybe WalletId
forall a. a -> Maybe a
Just WalletId
wid)
                    Either TextDecodingError WalletId
_ -> do
                        Tracer IO DBFactoryLog -> DBFactoryLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO DBFactoryLog
tr (DBFactoryLog -> IO ()) -> DBFactoryLog -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> DBFactoryLog
MsgUnknownDBFile FilePath
file
                        Maybe WalletId -> IO (Maybe WalletId)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe WalletId
forall a. Maybe a
Nothing
            (Bool, [Text])
_ -> Maybe WalletId -> IO (Maybe WalletId)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe WalletId
forall a. Maybe a
Nothing
  where
    expectedPrefix :: Text
expectedPrefix = FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Proxy k -> FilePath
forall (key :: Depth -> * -> *).
WalletKey key =>
Proxy key -> FilePath
keyTypeDescriptor (Proxy k -> FilePath) -> Proxy k -> FilePath
forall a b. (a -> b) -> a -> b
$ Proxy k
forall k (t :: k). Proxy t
Proxy @k

data DBFactoryLog
    = MsgFoundDatabase FilePath Text
    | MsgUnknownDBFile FilePath
    | MsgRemoving Text
    | MsgRemovingInUse Text Int
    | MsgRemovingDatabaseFile Text DeleteSqliteDatabaseLog
    | MsgWaitingForDatabase Text (Maybe Int)
    | MsgWalletDB FilePath WalletDBLog
    deriving ((forall x. DBFactoryLog -> Rep DBFactoryLog x)
-> (forall x. Rep DBFactoryLog x -> DBFactoryLog)
-> Generic DBFactoryLog
forall x. Rep DBFactoryLog x -> DBFactoryLog
forall x. DBFactoryLog -> Rep DBFactoryLog x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep DBFactoryLog x -> DBFactoryLog
$cfrom :: forall x. DBFactoryLog -> Rep DBFactoryLog x
Generic, Int -> DBFactoryLog -> FilePath -> FilePath
[DBFactoryLog] -> FilePath -> FilePath
DBFactoryLog -> FilePath
(Int -> DBFactoryLog -> FilePath -> FilePath)
-> (DBFactoryLog -> FilePath)
-> ([DBFactoryLog] -> FilePath -> FilePath)
-> Show DBFactoryLog
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [DBFactoryLog] -> FilePath -> FilePath
$cshowList :: [DBFactoryLog] -> FilePath -> FilePath
show :: DBFactoryLog -> FilePath
$cshow :: DBFactoryLog -> FilePath
showsPrec :: Int -> DBFactoryLog -> FilePath -> FilePath
$cshowsPrec :: Int -> DBFactoryLog -> FilePath -> FilePath
Show, DBFactoryLog -> DBFactoryLog -> Bool
(DBFactoryLog -> DBFactoryLog -> Bool)
-> (DBFactoryLog -> DBFactoryLog -> Bool) -> Eq DBFactoryLog
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DBFactoryLog -> DBFactoryLog -> Bool
$c/= :: DBFactoryLog -> DBFactoryLog -> Bool
== :: DBFactoryLog -> DBFactoryLog -> Bool
$c== :: DBFactoryLog -> DBFactoryLog -> Bool
Eq)

instance HasPrivacyAnnotation DBFactoryLog
instance HasSeverityAnnotation DBFactoryLog where
    getSeverityAnnotation :: DBFactoryLog -> Severity
getSeverityAnnotation DBFactoryLog
ev = case DBFactoryLog
ev of
        MsgFoundDatabase FilePath
_ Text
_ -> Severity
Info
        MsgUnknownDBFile FilePath
_ -> Severity
Notice
        MsgRemoving Text
_ -> Severity
Info
        MsgRemovingInUse Text
_ Int
_ -> Severity
Notice
        MsgRemovingDatabaseFile Text
_ DeleteSqliteDatabaseLog
msg -> DeleteSqliteDatabaseLog -> Severity
forall a. HasSeverityAnnotation a => a -> Severity
getSeverityAnnotation DeleteSqliteDatabaseLog
msg
        MsgWaitingForDatabase Text
_ Maybe Int
_ -> Severity
Info
        MsgWalletDB FilePath
_ WalletDBLog
msg -> WalletDBLog -> Severity
forall a. HasSeverityAnnotation a => a -> Severity
getSeverityAnnotation WalletDBLog
msg

instance ToText DBFactoryLog where
    toText :: DBFactoryLog -> Text
toText = \case
        MsgFoundDatabase FilePath
_file Text
wid ->
            Text
"Found existing wallet: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
wid
        MsgUnknownDBFile FilePath
file -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ Text
"Found something other than a database file in "
            , Text
"the database folder: ", FilePath -> Text
T.pack FilePath
file
            ]
        MsgRemoving Text
wid ->
            Text
"Removing wallet's database. Wallet id was " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
wid
        MsgRemovingDatabaseFile Text
wid DeleteSqliteDatabaseLog
msg ->
            Text
"Removing " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
wid Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> DeleteSqliteDatabaseLog -> Text
forall a. ToText a => a -> Text
toText DeleteSqliteDatabaseLog
msg
        MsgWaitingForDatabase Text
wid Maybe Int
Nothing ->
            Builder
"Database "Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+|Text
widText -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+Builder
" is ready to be deleted"
        MsgWaitingForDatabase Text
wid (Just Int
count) ->
            Builder
"Waiting for "Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+|Int
countInt -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+Builder
" withDatabase "Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+|Text
widText -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+Builder
" call(s) to finish"
        MsgRemovingInUse Text
wid Int
count ->
            Builder
"Timed out waiting for "Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+|Int
countInt -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+Builder
" withDatabase "Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+|Text
widText -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+Builder
" call(s) to finish. " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
            Builder
"Attempting to remove the database anyway."
        MsgWalletDB FilePath
_file WalletDBLog
msg -> WalletDBLog -> Text
forall a. ToText a => a -> Text
toText WalletDBLog
msg

{-------------------------------------------------------------------------------
                                 Database layer
-------------------------------------------------------------------------------}

-- | Runs an action with a connection to the SQLite database.
--
-- Database migrations are run to create tables if necessary.
--
-- If the given file path does not exist, it will be created by the sqlite
-- library.
withDBLayer
    :: forall s k a.
        ( PersistAddressBook s
        , PersistPrivateKey (k 'RootK)
        , WalletKey k
        )
    => Tracer IO WalletDBLog
       -- ^ Logging object
    -> DefaultFieldValues
       -- ^ Default database field values, used during migration.
    -> FilePath
       -- ^ Path to database file
    -> TimeInterpreter IO
       -- ^ Time interpreter for slot to time conversions
    -> (DBLayer IO s k -> IO a)
       -- ^ Action to run.
    -> IO a
withDBLayer :: Tracer IO WalletDBLog
-> DefaultFieldValues
-> FilePath
-> TimeInterpreter IO
-> (DBLayer IO s k -> IO a)
-> IO a
withDBLayer Tracer IO WalletDBLog
tr DefaultFieldValues
defaultFieldValues FilePath
dbFile TimeInterpreter IO
ti DBLayer IO s k -> IO a
action = do
    let trDB :: Tracer IO DBLog
trDB = (DBLog -> WalletDBLog) -> Tracer IO WalletDBLog -> Tracer IO DBLog
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap DBLog -> WalletDBLog
MsgDB Tracer IO WalletDBLog
tr
    let manualMigrations :: [ManualMigration]
manualMigrations = Tracer IO DBLog
-> Proxy k -> DefaultFieldValues -> [ManualMigration]
forall (k :: Depth -> * -> *).
WalletKey k =>
Tracer IO DBLog
-> Proxy k -> DefaultFieldValues -> [ManualMigration]
migrateManually Tracer IO DBLog
trDB (Proxy k
forall k (t :: k). Proxy t
Proxy @k) DefaultFieldValues
defaultFieldValues
    let autoMigrations :: Migration
autoMigrations   = Migration
migrateAll
    Tracer IO DBLog -> FilePath -> (ConnectionPool -> IO a) -> IO a
forall a.
Tracer IO DBLog -> FilePath -> (ConnectionPool -> IO a) -> IO a
withConnectionPool Tracer IO DBLog
trDB FilePath
dbFile ((ConnectionPool -> IO a) -> IO a)
-> (ConnectionPool -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \ConnectionPool
pool -> do
        Either MigrationError SqliteContext
res <- Tracer IO DBLog
-> ConnectionPool
-> [ManualMigration]
-> Migration
-> IO (Either MigrationError SqliteContext)
newSqliteContext Tracer IO DBLog
trDB ConnectionPool
pool [ManualMigration]
manualMigrations Migration
autoMigrations
        (MigrationError -> IO a)
-> (SqliteContext -> IO a)
-> Either MigrationError SqliteContext
-> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either MigrationError -> IO a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (DBLayer IO s k -> IO a
action (DBLayer IO s k -> IO a)
-> (SqliteContext -> IO (DBLayer IO s k)) -> SqliteContext -> IO a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< CacheBehavior
-> Tracer IO WalletDBLog
-> TimeInterpreter IO
-> SqliteContext
-> IO (DBLayer IO s k)
forall s (k :: Depth -> * -> *).
(PersistAddressBook s, PersistPrivateKey (k 'RootK)) =>
CacheBehavior
-> Tracer IO WalletDBLog
-> TimeInterpreter IO
-> SqliteContext
-> IO (DBLayer IO s k)
newDBLayerWith CacheBehavior
CacheLatestCheckpoint Tracer IO WalletDBLog
tr TimeInterpreter IO
ti) Either MigrationError SqliteContext
res

newtype WalletDBLog
    = MsgDB DBLog
    deriving ((forall x. WalletDBLog -> Rep WalletDBLog x)
-> (forall x. Rep WalletDBLog x -> WalletDBLog)
-> Generic WalletDBLog
forall x. Rep WalletDBLog x -> WalletDBLog
forall x. WalletDBLog -> Rep WalletDBLog x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep WalletDBLog x -> WalletDBLog
$cfrom :: forall x. WalletDBLog -> Rep WalletDBLog x
Generic, Int -> WalletDBLog -> FilePath -> FilePath
[WalletDBLog] -> FilePath -> FilePath
WalletDBLog -> FilePath
(Int -> WalletDBLog -> FilePath -> FilePath)
-> (WalletDBLog -> FilePath)
-> ([WalletDBLog] -> FilePath -> FilePath)
-> Show WalletDBLog
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [WalletDBLog] -> FilePath -> FilePath
$cshowList :: [WalletDBLog] -> FilePath -> FilePath
show :: WalletDBLog -> FilePath
$cshow :: WalletDBLog -> FilePath
showsPrec :: Int -> WalletDBLog -> FilePath -> FilePath
$cshowsPrec :: Int -> WalletDBLog -> FilePath -> FilePath
Show, WalletDBLog -> WalletDBLog -> Bool
(WalletDBLog -> WalletDBLog -> Bool)
-> (WalletDBLog -> WalletDBLog -> Bool) -> Eq WalletDBLog
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WalletDBLog -> WalletDBLog -> Bool
$c/= :: WalletDBLog -> WalletDBLog -> Bool
== :: WalletDBLog -> WalletDBLog -> Bool
$c== :: WalletDBLog -> WalletDBLog -> Bool
Eq)

instance HasPrivacyAnnotation WalletDBLog
instance HasSeverityAnnotation WalletDBLog where
    getSeverityAnnotation :: WalletDBLog -> Severity
getSeverityAnnotation = \case
        MsgDB DBLog
msg -> DBLog -> Severity
forall a. HasSeverityAnnotation a => a -> Severity
getSeverityAnnotation DBLog
msg

instance ToText WalletDBLog where
    toText :: WalletDBLog -> Text
toText = \case
        MsgDB DBLog
msg -> DBLog -> Text
forall a. ToText a => a -> Text
toText DBLog
msg

-- | Runs an IO action with a new 'DBLayer' backed by a sqlite in-memory
-- database.
withDBLayerInMemory
    :: forall s k a.
        ( PersistAddressBook s
        , PersistPrivateKey (k 'RootK)
        )
    => Tracer IO WalletDBLog
       -- ^ Logging object
    -> TimeInterpreter IO
       -- ^ Time interpreter for slot to time conversions
    -> (DBLayer IO s k -> IO a)
    -> IO a
withDBLayerInMemory :: Tracer IO WalletDBLog
-> TimeInterpreter IO -> (DBLayer IO s k -> IO a) -> IO a
withDBLayerInMemory Tracer IO WalletDBLog
tr TimeInterpreter IO
ti DBLayer IO s k -> IO a
action = IO (IO (), DBLayer IO s k)
-> ((IO (), DBLayer IO s k) -> IO ())
-> ((IO (), DBLayer IO s k) -> IO a)
-> IO a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (Tracer IO WalletDBLog
-> TimeInterpreter IO -> IO (IO (), DBLayer IO s k)
forall s (k :: Depth -> * -> *).
(PersistAddressBook s, PersistPrivateKey (k 'RootK)) =>
Tracer IO WalletDBLog
-> TimeInterpreter IO -> IO (IO (), DBLayer IO s k)
newDBLayerInMemory Tracer IO WalletDBLog
tr TimeInterpreter IO
ti) (IO (), DBLayer IO s k) -> IO ()
forall a b. (a, b) -> a
fst (DBLayer IO s k -> IO a
action (DBLayer IO s k -> IO a)
-> ((IO (), DBLayer IO s k) -> DBLayer IO s k)
-> (IO (), DBLayer IO s k)
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IO (), DBLayer IO s k) -> DBLayer IO s k
forall a b. (a, b) -> b
snd)

-- | Creates a 'DBLayer' backed by a sqlite in-memory database.
--
-- Returns a cleanup function which you should always use exactly once when
-- finished with the 'DBLayer'.
newDBLayerInMemory
    :: forall s k.
        ( PersistAddressBook s
        , PersistPrivateKey (k 'RootK)
        )
    => Tracer IO WalletDBLog
       -- ^ Logging object
    -> TimeInterpreter IO
       -- ^ Time interpreter for slot to time conversions
    -> IO (IO (), DBLayer IO s k)
newDBLayerInMemory :: Tracer IO WalletDBLog
-> TimeInterpreter IO -> IO (IO (), DBLayer IO s k)
newDBLayerInMemory Tracer IO WalletDBLog
tr TimeInterpreter IO
ti = do
    let tr' :: Tracer IO DBLog
tr' = (DBLog -> WalletDBLog) -> Tracer IO WalletDBLog -> Tracer IO DBLog
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap DBLog -> WalletDBLog
MsgDB Tracer IO WalletDBLog
tr
    (IO ()
destroy, SqliteContext
ctx) <-
        Tracer IO DBLog
-> [ManualMigration]
-> Migration
-> ForeignKeysSetting
-> IO (IO (), SqliteContext)
newInMemorySqliteContext Tracer IO DBLog
tr' [] Migration
migrateAll ForeignKeysSetting
ForeignKeysEnabled
    DBLayer IO s k
db <- Tracer IO WalletDBLog
-> TimeInterpreter IO -> SqliteContext -> IO (DBLayer IO s k)
forall s (k :: Depth -> * -> *).
(PersistAddressBook s, PersistPrivateKey (k 'RootK)) =>
Tracer IO WalletDBLog
-> TimeInterpreter IO -> SqliteContext -> IO (DBLayer IO s k)
newDBLayer Tracer IO WalletDBLog
tr TimeInterpreter IO
ti SqliteContext
ctx
    (IO (), DBLayer IO s k) -> IO (IO (), DBLayer IO s k)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO ()
destroy, DBLayer IO s k
db)

-- | What to do with regards to caching. This is useful to disable caching in
-- database benchmarks.
data CacheBehavior
    = NoCache
    | CacheLatestCheckpoint
    deriving (CacheBehavior -> CacheBehavior -> Bool
(CacheBehavior -> CacheBehavior -> Bool)
-> (CacheBehavior -> CacheBehavior -> Bool) -> Eq CacheBehavior
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CacheBehavior -> CacheBehavior -> Bool
$c/= :: CacheBehavior -> CacheBehavior -> Bool
== :: CacheBehavior -> CacheBehavior -> Bool
$c== :: CacheBehavior -> CacheBehavior -> Bool
Eq, Int -> CacheBehavior -> FilePath -> FilePath
[CacheBehavior] -> FilePath -> FilePath
CacheBehavior -> FilePath
(Int -> CacheBehavior -> FilePath -> FilePath)
-> (CacheBehavior -> FilePath)
-> ([CacheBehavior] -> FilePath -> FilePath)
-> Show CacheBehavior
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [CacheBehavior] -> FilePath -> FilePath
$cshowList :: [CacheBehavior] -> FilePath -> FilePath
show :: CacheBehavior -> FilePath
$cshow :: CacheBehavior -> FilePath
showsPrec :: Int -> CacheBehavior -> FilePath -> FilePath
$cshowsPrec :: Int -> CacheBehavior -> FilePath -> FilePath
Show)

-- | Sets up a connection to the SQLite database.
--
-- Database migrations are run to create tables if necessary.
--
-- If the given file path does not exist, it will be created by the sqlite
-- library.
--
-- 'newDBLayer' will provide the actual 'DBLayer' implementation. It requires an
-- 'SqliteContext' which can be obtained from a database connection pool. This
-- is better initialized with 'withDBLayer'.
newDBLayer
    :: forall s k.
        ( PersistAddressBook s
        , PersistPrivateKey (k 'RootK)
        )
    => Tracer IO WalletDBLog
       -- ^ Logging
    -> TimeInterpreter IO
       -- ^ Time interpreter for slot to time conversions
    -> SqliteContext
       -- ^ A (thread-)safe wrapper for query execution.
    -> IO (DBLayer IO s k)
newDBLayer :: Tracer IO WalletDBLog
-> TimeInterpreter IO -> SqliteContext -> IO (DBLayer IO s k)
newDBLayer = CacheBehavior
-> Tracer IO WalletDBLog
-> TimeInterpreter IO
-> SqliteContext
-> IO (DBLayer IO s k)
forall s (k :: Depth -> * -> *).
(PersistAddressBook s, PersistPrivateKey (k 'RootK)) =>
CacheBehavior
-> Tracer IO WalletDBLog
-> TimeInterpreter IO
-> SqliteContext
-> IO (DBLayer IO s k)
newDBLayerWith @s @k CacheBehavior
CacheLatestCheckpoint

{- HLINT ignore newDBLayerWith "Redundant <$>" -}
-- | Like 'newDBLayer', but allows to explicitly specify the caching behavior.
newDBLayerWith
    :: forall s k.
        ( PersistAddressBook s
        , PersistPrivateKey (k 'RootK)
        )
    => CacheBehavior
       -- ^ Option to disable caching.
    -> Tracer IO WalletDBLog
       -- ^ Logging
    -> TimeInterpreter IO
       -- ^ Time interpreter for slot to time conversions
    -> SqliteContext
       -- ^ A (thread-)safe wrapper for query execution.
    -> IO (DBLayer IO s k)
newDBLayerWith :: CacheBehavior
-> Tracer IO WalletDBLog
-> TimeInterpreter IO
-> SqliteContext
-> IO (DBLayer IO s k)
newDBLayerWith CacheBehavior
_cacheBehavior Tracer IO WalletDBLog
_tr TimeInterpreter IO
ti SqliteContext{forall a. SqlPersistT IO a -> IO a
$sel:runQuery:SqliteContext :: SqliteContext -> forall a. SqlPersistT IO a -> IO a
runQuery :: forall a. SqlPersistT IO a -> IO a
runQuery} = do
    -- FIXME LATER during ADP-1043:
    --   Remove the 'NoCache' behavior, we cannot get it back.
    --   This will affect read benchmarks, they will need to benchmark
    --   'loadDBVar' instead.

    -- FIXME LATER during ADP-1043:
    --   Handle the case where loading the database fails.
    DBVar (SqlPersistT IO) (DeltaMap WalletId (DeltaWalletState s))
walletsDB_ <- SqlPersistT
  IO
  (DBVar (SqlPersistT IO) (DeltaMap WalletId (DeltaWalletState s)))
-> IO
     (DBVar (SqlPersistT IO) (DeltaMap WalletId (DeltaWalletState s)))
forall a. SqlPersistT IO a -> IO a
runQuery (SqlPersistT
   IO
   (DBVar (SqlPersistT IO) (DeltaMap WalletId (DeltaWalletState s)))
 -> IO
      (DBVar (SqlPersistT IO) (DeltaMap WalletId (DeltaWalletState s))))
-> SqlPersistT
     IO
     (DBVar (SqlPersistT IO) (DeltaMap WalletId (DeltaWalletState s)))
-> IO
     (DBVar (SqlPersistT IO) (DeltaMap WalletId (DeltaWalletState s)))
forall a b. (a -> b) -> a -> b
$ Store (SqlPersistT IO) (DeltaMap WalletId (DeltaWalletState s))
-> SqlPersistT
     IO
     (DBVar (SqlPersistT IO) (DeltaMap WalletId (DeltaWalletState s)))
forall (m :: * -> *) da.
(MonadSTM m, MonadThrow m, MonadEvaluate m, MonadMask m,
 Delta da) =>
Store m da -> m (DBVar m da)
loadDBVar Store (SqlPersistT IO) (DeltaMap WalletId (DeltaWalletState s))
forall s key.
(PersistAddressBook s, key ~ WalletId) =>
Store (SqlPersistT IO) (DeltaMap key (DeltaWalletState s))
mkStoreWallets
    DBVar (SqlPersistT IO) DeltaTxWalletsHistory
transactionsDBVar <- SqlPersistT IO (DBVar (SqlPersistT IO) DeltaTxWalletsHistory)
-> IO (DBVar (SqlPersistT IO) DeltaTxWalletsHistory)
forall a. SqlPersistT IO a -> IO a
runQuery (SqlPersistT IO (DBVar (SqlPersistT IO) DeltaTxWalletsHistory)
 -> IO (DBVar (SqlPersistT IO) DeltaTxWalletsHistory))
-> SqlPersistT IO (DBVar (SqlPersistT IO) DeltaTxWalletsHistory)
-> IO (DBVar (SqlPersistT IO) DeltaTxWalletsHistory)
forall a b. (a -> b) -> a -> b
$ Store (SqlPersistT IO) DeltaTxWalletsHistory
-> SqlPersistT IO (DBVar (SqlPersistT IO) DeltaTxWalletsHistory)
forall (m :: * -> *) da.
(MonadSTM m, MonadThrow m, MonadEvaluate m, MonadMask m,
 Delta da) =>
Store m da -> m (DBVar m da)
loadDBVar Store (SqlPersistT IO) DeltaTxWalletsHistory
mkStoreTxWalletsHistory

    -- NOTE
    -- The cache will not work properly unless 'atomically' is protected by a
    -- mutex (queryLock), which means no concurrent queries.
    MVar ()
queryLock <- () -> IO (MVar ())
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar () -- fixme: ADP-586

    -- Insert genesis checkpoint into the DBVar.
    -- Throws an internal error if the checkpoint is not actually at genesis.
    let insertCheckpointGenesis :: WalletId -> Wallet s -> SqlPersistT IO ()
insertCheckpointGenesis WalletId
wid Wallet s
cp =
            case Wallet s -> Maybe (WalletState s)
forall s. AddressBookIso s => Wallet s -> Maybe (WalletState s)
fromGenesis Wallet s
cp of
                Maybe (WalletState s)
Nothing -> ErrInitializeGenesisAbsent -> SqlPersistT IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (ErrInitializeGenesisAbsent -> SqlPersistT IO ())
-> ErrInitializeGenesisAbsent -> SqlPersistT IO ()
forall a b. (a -> b) -> a -> b
$ WalletId -> BlockHeader -> ErrInitializeGenesisAbsent
ErrInitializeGenesisAbsent WalletId
wid BlockHeader
header
                Just WalletState s
wallet ->
                    DBVar (SqlPersistT IO) (DeltaMap WalletId (DeltaWalletState s))
-> DeltaMap WalletId (DeltaWalletState s) -> SqlPersistT IO ()
forall da (m :: * -> *).
(Delta da, Monad m) =>
DBVar m da -> da -> m ()
updateDBVar DBVar (SqlPersistT IO) (DeltaMap WalletId (DeltaWalletState s))
walletsDB_ (DeltaMap WalletId (DeltaWalletState s) -> SqlPersistT IO ())
-> DeltaMap WalletId (DeltaWalletState s) -> SqlPersistT IO ()
forall a b. (a -> b) -> a -> b
$ WalletId
-> Base (DeltaWalletState s)
-> DeltaMap WalletId (DeltaWalletState s)
forall key da. key -> Base da -> DeltaMap key da
Insert WalletId
wid Base (DeltaWalletState s)
WalletState s
wallet
          where
            header :: BlockHeader
header = Wallet s
cp Wallet s
-> ((BlockHeader -> Const BlockHeader BlockHeader)
    -> Wallet s -> Const BlockHeader (Wallet s))
-> BlockHeader
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "currentTip"
  ((BlockHeader -> Const BlockHeader BlockHeader)
   -> Wallet s -> Const BlockHeader (Wallet s))
(BlockHeader -> Const BlockHeader BlockHeader)
-> Wallet s -> Const BlockHeader (Wallet s)
#currentTip

    -- Retrieve the latest checkpoint from the DBVar
    let readCheckpoint_
            :: W.WalletId
            -> SqlPersistT IO (Maybe (W.Wallet s))
        readCheckpoint_ :: WalletId -> SqlPersistT IO (Maybe (Wallet s))
readCheckpoint_ WalletId
wid =
            (WalletState s -> Wallet s)
-> Maybe (WalletState s) -> Maybe (Wallet s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap WalletState s -> Wallet s
forall s. AddressBookIso s => WalletState s -> Wallet s
getLatest (Maybe (WalletState s) -> Maybe (Wallet s))
-> (Map WalletId (WalletState s) -> Maybe (WalletState s))
-> Map WalletId (WalletState s)
-> Maybe (Wallet s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WalletId -> Map WalletId (WalletState s) -> Maybe (WalletState s)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup WalletId
wid (Map WalletId (WalletState s) -> Maybe (Wallet s))
-> SqlPersistT IO (Map WalletId (WalletState s))
-> SqlPersistT IO (Maybe (Wallet s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DBVar (SqlPersistT IO) (DeltaMap WalletId (DeltaWalletState s))
-> SqlPersistT IO (Map WalletId (WalletState s))
forall da a (m :: * -> *).
(Delta da, a ~ Base da) =>
DBVar m da -> m a
readDBVar DBVar (SqlPersistT IO) (DeltaMap WalletId (DeltaWalletState s))
walletsDB_

    let pruneCheckpoints
            :: W.WalletId
            -> Quantity "block" Word32 -> W.BlockHeader
            -> SqlPersistT IO ()
        pruneCheckpoints :: WalletId
-> Quantity "block" Word32 -> BlockHeader -> SqlPersistT IO ()
pruneCheckpoints WalletId
wid Quantity "block" Word32
epochStability BlockHeader
tip = do
            let heights :: Set Word32
heights = [Word32] -> Set Word32
forall a. Ord a => [a] -> Set a
Set.fromList ([Word32] -> Set Word32) -> [Word32] -> Set Word32
forall a b. (a -> b) -> a -> b
$ SparseCheckpointsConfig -> Quantity "block" Word32 -> [Word32]
sparseCheckpoints
                    (Quantity "block" Word32 -> SparseCheckpointsConfig
defaultSparseCheckpointsConfig Quantity "block" Word32
epochStability)
                    (BlockHeader
tip BlockHeader
-> ((Quantity "block" Word32
     -> Const (Quantity "block" Word32) (Quantity "block" Word32))
    -> BlockHeader -> Const (Quantity "block" Word32) BlockHeader)
-> Quantity "block" Word32
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "blockHeight"
  ((Quantity "block" Word32
    -> Const (Quantity "block" Word32) (Quantity "block" Word32))
   -> BlockHeader -> Const (Quantity "block" Word32) BlockHeader)
(Quantity "block" Word32
 -> Const (Quantity "block" Word32) (Quantity "block" Word32))
-> BlockHeader -> Const (Quantity "block" Word32) BlockHeader
#blockHeight)
            DBVar (SqlPersistT IO) (DeltaMap WalletId (DeltaWalletState s))
-> (Map WalletId (WalletState s)
    -> (Maybe (DeltaMap WalletId (DeltaWalletState s)), ()))
-> SqlPersistT IO ()
forall da (m :: * -> *) a b.
(Delta da, Monad m, a ~ Base da) =>
DBVar m da -> (a -> (Maybe da, b)) -> m b
modifyDBMaybe DBVar (SqlPersistT IO) (DeltaMap WalletId (DeltaWalletState s))
walletsDB_ ((Map WalletId (WalletState s)
  -> (Maybe (DeltaMap WalletId (DeltaWalletState s)), ()))
 -> SqlPersistT IO ())
-> (Map WalletId (WalletState s)
    -> (Maybe (DeltaMap WalletId (DeltaWalletState s)), ()))
-> SqlPersistT IO ()
forall a b. (a -> b) -> a -> b
$ \Map WalletId (WalletState s)
ws ->
                case WalletId -> Map WalletId (WalletState s) -> Maybe (WalletState s)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup WalletId
wid Map WalletId (WalletState s)
ws of
                    Maybe (WalletState s)
Nothing  -> (Maybe (DeltaMap WalletId (DeltaWalletState s))
forall a. Maybe a
Nothing, ())
                    Just WalletState s
wal ->
                        let willKeep :: WalletCheckpoint s -> Bool
willKeep WalletCheckpoint s
cp = WalletCheckpoint s -> Word32
forall s. WalletCheckpoint s -> Word32
getBlockHeight WalletCheckpoint s
cp Word32 -> Set Word32 -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Word32
heights
                            slots :: Map Slot (WalletCheckpoint s)
slots = (WalletCheckpoint s -> Bool)
-> Map Slot (WalletCheckpoint s) -> Map Slot (WalletCheckpoint s)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter WalletCheckpoint s -> Bool
forall s. WalletCheckpoint s -> Bool
willKeep (WalletState s
wal WalletState s
-> ((Map Slot (WalletCheckpoint s)
     -> Const
          (Map Slot (WalletCheckpoint s)) (Map Slot (WalletCheckpoint s)))
    -> WalletState s
    -> Const (Map Slot (WalletCheckpoint s)) (WalletState s))
-> Map Slot (WalletCheckpoint s)
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "checkpoints"
  ((Checkpoints (WalletCheckpoint s)
    -> Const
         (Map Slot (WalletCheckpoint s)) (Checkpoints (WalletCheckpoint s)))
   -> WalletState s
   -> Const (Map Slot (WalletCheckpoint s)) (WalletState s))
(Checkpoints (WalletCheckpoint s)
 -> Const
      (Map Slot (WalletCheckpoint s)) (Checkpoints (WalletCheckpoint s)))
-> WalletState s
-> Const (Map Slot (WalletCheckpoint s)) (WalletState s)
#checkpoints ((Checkpoints (WalletCheckpoint s)
  -> Const
       (Map Slot (WalletCheckpoint s)) (Checkpoints (WalletCheckpoint s)))
 -> WalletState s
 -> Const (Map Slot (WalletCheckpoint s)) (WalletState s))
-> ((Map Slot (WalletCheckpoint s)
     -> Const
          (Map Slot (WalletCheckpoint s)) (Map Slot (WalletCheckpoint s)))
    -> Checkpoints (WalletCheckpoint s)
    -> Const
         (Map Slot (WalletCheckpoint s)) (Checkpoints (WalletCheckpoint s)))
-> (Map Slot (WalletCheckpoint s)
    -> Const
         (Map Slot (WalletCheckpoint s)) (Map Slot (WalletCheckpoint s)))
-> WalletState s
-> Const (Map Slot (WalletCheckpoint s)) (WalletState s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IsLabel
  "checkpoints"
  ((Map Slot (WalletCheckpoint s)
    -> Const
         (Map Slot (WalletCheckpoint s)) (Map Slot (WalletCheckpoint s)))
   -> Checkpoints (WalletCheckpoint s)
   -> Const
        (Map Slot (WalletCheckpoint s)) (Checkpoints (WalletCheckpoint s)))
(Map Slot (WalletCheckpoint s)
 -> Const
      (Map Slot (WalletCheckpoint s)) (Map Slot (WalletCheckpoint s)))
-> Checkpoints (WalletCheckpoint s)
-> Const
     (Map Slot (WalletCheckpoint s)) (Checkpoints (WalletCheckpoint s))
#checkpoints)
                            delta :: DeltaMap WalletId [DeltaWalletState1 s]
delta = WalletId
-> [DeltaWalletState1 s] -> DeltaMap WalletId [DeltaWalletState1 s]
forall key da. key -> da -> DeltaMap key da
Adjust WalletId
wid
                                [ DeltasCheckpoints (WalletCheckpoint s) -> DeltaWalletState1 s
forall s.
DeltasCheckpoints (WalletCheckpoint s) -> DeltaWalletState1 s
UpdateCheckpoints [ [Slot] -> DeltaCheckpoints (WalletCheckpoint s)
forall a. [Slot] -> DeltaCheckpoints a
RestrictTo ([Slot] -> DeltaCheckpoints (WalletCheckpoint s))
-> [Slot] -> DeltaCheckpoints (WalletCheckpoint s)
forall a b. (a -> b) -> a -> b
$ Map Slot (WalletCheckpoint s) -> [Slot]
forall k a. Map k a -> [k]
Map.keys Map Slot (WalletCheckpoint s)
slots ] ]
                        in  (DeltaMap WalletId (DeltaWalletState s)
-> Maybe (DeltaMap WalletId (DeltaWalletState s))
forall a. a -> Maybe a
Just DeltaMap WalletId (DeltaWalletState s)
forall s. DeltaMap WalletId [DeltaWalletState1 s]
delta, ())

    -- Delete the a wallet from the checkpoint DBVar
    let deleteCheckpoints :: W.WalletId -> SqlPersistT IO ()
        deleteCheckpoints :: WalletId -> SqlPersistT IO ()
deleteCheckpoints WalletId
wid = DBVar (SqlPersistT IO) (DeltaMap WalletId (DeltaWalletState s))
-> DeltaMap WalletId (DeltaWalletState s) -> SqlPersistT IO ()
forall da (m :: * -> *).
(Delta da, Monad m) =>
DBVar m da -> da -> m ()
updateDBVar DBVar (SqlPersistT IO) (DeltaMap WalletId (DeltaWalletState s))
walletsDB_ (DeltaMap WalletId (DeltaWalletState s) -> SqlPersistT IO ())
-> DeltaMap WalletId (DeltaWalletState s) -> SqlPersistT IO ()
forall a b. (a -> b) -> a -> b
$ WalletId -> DeltaMap WalletId (DeltaWalletState s)
forall key da. key -> DeltaMap key da
Delete WalletId
wid

    DBLayer IO s k -> IO (DBLayer IO s k)
forall (m :: * -> *) a. Monad m => a -> m a
return DBLayer :: forall (m :: * -> *) s (k :: Depth -> * -> *) (stm :: * -> *).
(MonadIO stm, MonadFail stm) =>
(WalletId
 -> Wallet s
 -> WalletMetadata
 -> [(Tx, TxMeta)]
 -> GenesisParameters
 -> ExceptT ErrWalletAlreadyExists stm ())
-> (WalletId -> ExceptT ErrNoSuchWallet stm ())
-> stm [WalletId]
-> DBVar stm (DeltaMap WalletId (DeltaWalletState s))
-> (WalletId -> Wallet s -> ExceptT ErrNoSuchWallet stm ())
-> (WalletId -> stm (Maybe (Wallet s)))
-> (WalletId -> stm [ChainPoint])
-> (WalletId -> WalletMetadata -> ExceptT ErrNoSuchWallet stm ())
-> (WalletId -> stm (Maybe WalletMetadata))
-> (WalletId -> ExceptT ErrNoSuchWallet stm Bool)
-> (WalletId
    -> DelegationCertificate
    -> SlotNo
    -> ExceptT ErrNoSuchWallet stm ())
-> (WalletId -> Coin -> ExceptT ErrNoSuchWallet stm ())
-> (WalletId -> stm Coin)
-> (WalletId -> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet stm ())
-> (WalletId
    -> Maybe Coin
    -> SortOrder
    -> Range SlotNo
    -> Maybe TxStatus
    -> stm [TransactionInfo])
-> (WalletId
    -> Hash "Tx"
    -> ExceptT ErrNoSuchWallet stm (Maybe TransactionInfo))
-> (WalletId
    -> Hash "Tx"
    -> SealedTx
    -> SlotNo
    -> ExceptT ErrPutLocalTxSubmission stm ())
-> (WalletId -> stm [LocalTxSubmissionStatus SealedTx])
-> (WalletId -> SlotNo -> ExceptT ErrNoSuchWallet stm ())
-> (WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx stm ())
-> (WalletId
    -> (k 'RootK XPrv, PassphraseHash)
    -> ExceptT ErrNoSuchWallet stm ())
-> (WalletId -> stm (Maybe (k 'RootK XPrv, PassphraseHash)))
-> (WalletId -> stm (Maybe GenesisParameters))
-> (WalletId -> Slot -> ExceptT ErrNoSuchWallet stm ChainPoint)
-> (WalletId
    -> Quantity "block" Word32 -> ExceptT ErrNoSuchWallet stm ())
-> (forall a. stm a -> m a)
-> DBLayer m s k
DBLayer

        {-----------------------------------------------------------------------
                                      Wallets
        -----------------------------------------------------------------------}

        { initializeWallet :: WalletId
-> Wallet s
-> WalletMetadata
-> [(Tx, TxMeta)]
-> GenesisParameters
-> ExceptT ErrWalletAlreadyExists (SqlPersistT IO) ()
initializeWallet = \WalletId
wid Wallet s
cp WalletMetadata
meta [(Tx, TxMeta)]
txs GenesisParameters
gp -> do
            ReaderT SqlBackend IO (Either ErrWalletAlreadyExists ())
-> ExceptT ErrWalletAlreadyExists (SqlPersistT IO) ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT SqlBackend IO (Either ErrWalletAlreadyExists ())
 -> ExceptT ErrWalletAlreadyExists (SqlPersistT IO) ())
-> ReaderT SqlBackend IO (Either ErrWalletAlreadyExists ())
-> ExceptT ErrWalletAlreadyExists (SqlPersistT IO) ()
forall a b. (a -> b) -> a -> b
$ do
                Either ErrWalletAlreadyExists ()
res <- ErrWalletAlreadyExists
-> SqlPersistT IO ()
-> ReaderT SqlBackend IO (Either ErrWalletAlreadyExists ())
forall (m :: * -> *) e a.
MonadUnliftIO m =>
e -> m a -> m (Either e a)
handleConstraint (WalletId -> ErrWalletAlreadyExists
ErrWalletAlreadyExists WalletId
wid) (SqlPersistT IO ()
 -> ReaderT SqlBackend IO (Either ErrWalletAlreadyExists ()))
-> SqlPersistT IO ()
-> ReaderT SqlBackend IO (Either ErrWalletAlreadyExists ())
forall a b. (a -> b) -> a -> b
$
                    Wallet -> SqlPersistT IO ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
record -> ReaderT backend m ()
insert_ (WalletId -> WalletMetadata -> GenesisParameters -> Wallet
mkWalletEntity WalletId
wid WalletMetadata
meta GenesisParameters
gp)
                Bool -> SqlPersistT IO () -> SqlPersistT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Either ErrWalletAlreadyExists () -> Bool
forall a b. Either a b -> Bool
isRight Either ErrWalletAlreadyExists ()
res) (SqlPersistT IO () -> SqlPersistT IO ())
-> SqlPersistT IO () -> SqlPersistT IO ()
forall a b. (a -> b) -> a -> b
$ do
                    WalletId -> Wallet s -> SqlPersistT IO ()
insertCheckpointGenesis WalletId
wid Wallet s
cp
                    SqlPersistT IO (Either Any ()) -> SqlPersistT IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (SqlPersistT IO (Either Any ()) -> SqlPersistT IO ())
-> SqlPersistT IO (Either Any ()) -> SqlPersistT IO ()
forall a b. (a -> b) -> a -> b
$ DBVar (SqlPersistT IO) DeltaTxWalletsHistory
-> ((TxHistory, Map WalletId TxMetaHistory)
    -> (Maybe DeltaTxWalletsHistory, Either Any ()))
-> SqlPersistT IO (Either Any ())
forall da (m :: * -> *) a b.
(Delta da, Monad m, a ~ Base da) =>
DBVar m da -> (a -> (Maybe da, b)) -> m b
modifyDBMaybe DBVar (SqlPersistT IO) DeltaTxWalletsHistory
transactionsDBVar (((TxHistory, Map WalletId TxMetaHistory)
  -> (Maybe DeltaTxWalletsHistory, Either Any ()))
 -> SqlPersistT IO (Either Any ()))
-> ((TxHistory, Map WalletId TxMetaHistory)
    -> (Maybe DeltaTxWalletsHistory, Either Any ()))
-> SqlPersistT IO (Either Any ())
forall a b. (a -> b) -> a -> b
$ \(TxHistory
_txsOld, Map WalletId TxMetaHistory
_ws) ->
                        let delta :: Maybe DeltaTxWalletsHistory
delta = DeltaTxWalletsHistory -> Maybe DeltaTxWalletsHistory
forall a. a -> Maybe a
Just (DeltaTxWalletsHistory -> Maybe DeltaTxWalletsHistory)
-> DeltaTxWalletsHistory -> Maybe DeltaTxWalletsHistory
forall a b. (a -> b) -> a -> b
$ WalletId -> [(Tx, TxMeta)] -> DeltaTxWalletsHistory
ExpandTxWalletsHistory WalletId
wid [(Tx, TxMeta)]
txs
                        in  (Maybe DeltaTxWalletsHistory
delta, () -> Either Any ()
forall a b. b -> Either a b
Right ())
                Either ErrWalletAlreadyExists ()
-> ReaderT SqlBackend IO (Either ErrWalletAlreadyExists ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either ErrWalletAlreadyExists ()
res
        , removeWallet :: WalletId -> ExceptT ErrNoSuchWallet (SqlPersistT IO) ()
removeWallet = \WalletId
wid -> do
            ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
-> ExceptT ErrNoSuchWallet (SqlPersistT IO) ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
 -> ExceptT ErrNoSuchWallet (SqlPersistT IO) ())
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
-> ExceptT ErrNoSuchWallet (SqlPersistT IO) ()
forall a b. (a -> b) -> a -> b
$ do
                WalletId -> SqlPersistT IO (Maybe Wallet)
forall (m :: * -> *).
MonadIO m =>
WalletId -> SqlPersistT m (Maybe Wallet)
selectWallet WalletId
wid SqlPersistT IO (Maybe Wallet)
-> (Maybe Wallet
    -> ReaderT SqlBackend IO (Either ErrNoSuchWallet ()))
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                    Maybe Wallet
Nothing -> Either ErrNoSuchWallet ()
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrNoSuchWallet ()
 -> ReaderT SqlBackend IO (Either ErrNoSuchWallet ()))
-> Either ErrNoSuchWallet ()
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall a b. (a -> b) -> a -> b
$ ErrNoSuchWallet -> Either ErrNoSuchWallet ()
forall a b. a -> Either a b
Left (ErrNoSuchWallet -> Either ErrNoSuchWallet ())
-> ErrNoSuchWallet -> Either ErrNoSuchWallet ()
forall a b. (a -> b) -> a -> b
$ WalletId -> ErrNoSuchWallet
ErrNoSuchWallet WalletId
wid
                    Just Wallet
_  -> () -> Either ErrNoSuchWallet ()
forall a b. b -> Either a b
Right (() -> Either ErrNoSuchWallet ())
-> SqlPersistT IO ()
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
                        [Filter Wallet] -> SqlPersistT IO ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere [EntityField Wallet WalletId
forall typ. (typ ~ WalletId) => EntityField Wallet typ
WalId EntityField Wallet WalletId -> WalletId -> Filter Wallet
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. WalletId
wid]
                        WalletId -> SqlPersistT IO ()
deleteCheckpoints WalletId
wid
            ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
-> ExceptT ErrNoSuchWallet (SqlPersistT IO) ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
 -> ExceptT ErrNoSuchWallet (SqlPersistT IO) ())
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
-> ExceptT ErrNoSuchWallet (SqlPersistT IO) ()
forall a b. (a -> b) -> a -> b
$ DBVar (SqlPersistT IO) DeltaTxWalletsHistory
-> ((TxHistory, Map WalletId TxMetaHistory)
    -> (Maybe DeltaTxWalletsHistory, Either ErrNoSuchWallet ()))
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall da (m :: * -> *) a b.
(Delta da, Monad m, a ~ Base da) =>
DBVar m da -> (a -> (Maybe da, b)) -> m b
modifyDBMaybe DBVar (SqlPersistT IO) DeltaTxWalletsHistory
transactionsDBVar (((TxHistory, Map WalletId TxMetaHistory)
  -> (Maybe DeltaTxWalletsHistory, Either ErrNoSuchWallet ()))
 -> ReaderT SqlBackend IO (Either ErrNoSuchWallet ()))
-> ((TxHistory, Map WalletId TxMetaHistory)
    -> (Maybe DeltaTxWalletsHistory, Either ErrNoSuchWallet ()))
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall a b. (a -> b) -> a -> b
$ \(TxHistory, Map WalletId TxMetaHistory)
_ ->
                        let
                            delta :: Maybe DeltaTxWalletsHistory
delta = DeltaTxWalletsHistory -> Maybe DeltaTxWalletsHistory
forall a. a -> Maybe a
Just (DeltaTxWalletsHistory -> Maybe DeltaTxWalletsHistory)
-> DeltaTxWalletsHistory -> Maybe DeltaTxWalletsHistory
forall a b. (a -> b) -> a -> b
$ WalletId -> DeltaTxWalletsHistory
RemoveWallet WalletId
wid
                        in  (Maybe DeltaTxWalletsHistory
delta, () -> Either ErrNoSuchWallet ()
forall a b. b -> Either a b
Right ())
            ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
-> ExceptT ErrNoSuchWallet (SqlPersistT IO) ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
 -> ExceptT ErrNoSuchWallet (SqlPersistT IO) ())
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
-> ExceptT ErrNoSuchWallet (SqlPersistT IO) ()
forall a b. (a -> b) -> a -> b
$ DBVar (SqlPersistT IO) DeltaTxWalletsHistory
-> ((TxHistory, Map WalletId TxMetaHistory)
    -> (Maybe DeltaTxWalletsHistory, Either ErrNoSuchWallet ()))
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall da (m :: * -> *) a b.
(Delta da, Monad m, a ~ Base da) =>
DBVar m da -> (a -> (Maybe da, b)) -> m b
modifyDBMaybe DBVar (SqlPersistT IO) DeltaTxWalletsHistory
transactionsDBVar (((TxHistory, Map WalletId TxMetaHistory)
  -> (Maybe DeltaTxWalletsHistory, Either ErrNoSuchWallet ()))
 -> ReaderT SqlBackend IO (Either ErrNoSuchWallet ()))
-> ((TxHistory, Map WalletId TxMetaHistory)
    -> (Maybe DeltaTxWalletsHistory, Either ErrNoSuchWallet ()))
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall a b. (a -> b) -> a -> b
$ \(TxHistory, Map WalletId TxMetaHistory)
_ ->
                        let
                            delta :: Maybe DeltaTxWalletsHistory
delta = DeltaTxWalletsHistory -> Maybe DeltaTxWalletsHistory
forall a. a -> Maybe a
Just DeltaTxWalletsHistory
GarbageCollectTxWalletsHistory
                        in  (Maybe DeltaTxWalletsHistory
delta, () -> Either ErrNoSuchWallet ()
forall a b. b -> Either a b
Right ())
        , listWallets :: ReaderT SqlBackend IO [WalletId]
listWallets = (Key Wallet -> WalletId) -> [Key Wallet] -> [WalletId]
forall a b. (a -> b) -> [a] -> [b]
map Key Wallet -> WalletId
unWalletKey ([Key Wallet] -> [WalletId])
-> ReaderT SqlBackend IO [Key Wallet]
-> ReaderT SqlBackend IO [WalletId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Filter Wallet]
-> [SelectOpt Wallet] -> ReaderT SqlBackend IO [Key Wallet]
forall record backend (m :: * -> *).
(MonadIO m, PersistQueryRead backend,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m [Key record]
selectKeysList [] [EntityField Wallet WalletId -> SelectOpt Wallet
forall record typ. EntityField record typ -> SelectOpt record
Asc EntityField Wallet WalletId
forall typ. (typ ~ WalletId) => EntityField Wallet typ
WalId]

        {-----------------------------------------------------------------------
                                    Checkpoints
        -----------------------------------------------------------------------}
        , walletsDB :: DBVar (SqlPersistT IO) (DeltaMap WalletId (DeltaWalletState s))
walletsDB = DBVar (SqlPersistT IO) (DeltaMap WalletId (DeltaWalletState s))
walletsDB_

        , putCheckpoint :: WalletId -> Wallet s -> ExceptT ErrNoSuchWallet (SqlPersistT IO) ()
putCheckpoint = \WalletId
wid Wallet s
cp -> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
-> ExceptT ErrNoSuchWallet (SqlPersistT IO) ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
 -> ExceptT ErrNoSuchWallet (SqlPersistT IO) ())
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
-> ExceptT ErrNoSuchWallet (SqlPersistT IO) ()
forall a b. (a -> b) -> a -> b
$ do
            DBVar (SqlPersistT IO) (DeltaMap WalletId (DeltaWalletState s))
-> (Map WalletId (WalletState s)
    -> (Maybe (DeltaMap WalletId (DeltaWalletState s)),
        Either ErrNoSuchWallet ()))
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall da (m :: * -> *) a b.
(Delta da, Monad m, a ~ Base da) =>
DBVar m da -> (a -> (Maybe da, b)) -> m b
modifyDBMaybe DBVar (SqlPersistT IO) (DeltaMap WalletId (DeltaWalletState s))
walletsDB_ ((Map WalletId (WalletState s)
  -> (Maybe (DeltaMap WalletId (DeltaWalletState s)),
      Either ErrNoSuchWallet ()))
 -> ReaderT SqlBackend IO (Either ErrNoSuchWallet ()))
-> (Map WalletId (WalletState s)
    -> (Maybe (DeltaMap WalletId (DeltaWalletState s)),
        Either ErrNoSuchWallet ()))
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall a b. (a -> b) -> a -> b
$ \Map WalletId (WalletState s)
ws ->
                case WalletId -> Map WalletId (WalletState s) -> Maybe (WalletState s)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup WalletId
wid Map WalletId (WalletState s)
ws of
                    Maybe (WalletState s)
Nothing -> (Maybe (DeltaMap WalletId (DeltaWalletState s))
forall a. Maybe a
Nothing, ErrNoSuchWallet -> Either ErrNoSuchWallet ()
forall a b. a -> Either a b
Left (ErrNoSuchWallet -> Either ErrNoSuchWallet ())
-> ErrNoSuchWallet -> Either ErrNoSuchWallet ()
forall a b. (a -> b) -> a -> b
$ WalletId -> ErrNoSuchWallet
ErrNoSuchWallet WalletId
wid)
                    Just WalletState s
_  ->
                        let (Prologue s
prologue, WalletCheckpoint s
wcp) = Wallet s -> (Prologue s, WalletCheckpoint s)
forall s.
AddressBookIso s =>
Wallet s -> (Prologue s, WalletCheckpoint s)
fromWallet Wallet s
cp
                            slot :: Slot
slot = WalletCheckpoint s -> Slot
forall s. WalletCheckpoint s -> Slot
getSlot WalletCheckpoint s
wcp
                            delta :: Maybe (DeltaMap WalletId (DeltaWalletState s))
delta = DeltaMap WalletId (DeltaWalletState s)
-> Maybe (DeltaMap WalletId (DeltaWalletState s))
forall a. a -> Maybe a
Just (DeltaMap WalletId (DeltaWalletState s)
 -> Maybe (DeltaMap WalletId (DeltaWalletState s)))
-> DeltaMap WalletId (DeltaWalletState s)
-> Maybe (DeltaMap WalletId (DeltaWalletState s))
forall a b. (a -> b) -> a -> b
$ WalletId
-> DeltaWalletState s -> DeltaMap WalletId (DeltaWalletState s)
forall key da. key -> da -> DeltaMap key da
Adjust WalletId
wid
                                [ DeltasCheckpoints (WalletCheckpoint s) -> DeltaWalletState1 s
forall s.
DeltasCheckpoints (WalletCheckpoint s) -> DeltaWalletState1 s
UpdateCheckpoints [ Slot -> WalletCheckpoint s -> DeltaCheckpoints (WalletCheckpoint s)
forall a. Slot -> a -> DeltaCheckpoints a
PutCheckpoint Slot
slot WalletCheckpoint s
wcp ]
                                , Prologue s -> DeltaWalletState1 s
forall s. Prologue s -> DeltaWalletState1 s
ReplacePrologue Prologue s
prologue
                                ]
                        in  (Maybe (DeltaMap WalletId (DeltaWalletState s))
delta, () -> Either ErrNoSuchWallet ()
forall a b. b -> Either a b
Right ())

        , readCheckpoint :: WalletId -> SqlPersistT IO (Maybe (Wallet s))
readCheckpoint = WalletId -> SqlPersistT IO (Maybe (Wallet s))
readCheckpoint_

        , listCheckpoints :: WalletId -> ReaderT SqlBackend IO [ChainPoint]
listCheckpoints = \WalletId
wid -> do
            let toChainPoint :: BlockHeader -> ChainPoint
toChainPoint = BlockHeader -> ChainPoint
W.chainPointFromBlockHeader
            (Entity Checkpoint -> ChainPoint)
-> [Entity Checkpoint] -> [ChainPoint]
forall a b. (a -> b) -> [a] -> [b]
map (BlockHeader -> ChainPoint
toChainPoint (BlockHeader -> ChainPoint)
-> (Entity Checkpoint -> BlockHeader)
-> Entity Checkpoint
-> ChainPoint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Checkpoint -> BlockHeader
blockHeaderFromEntity (Checkpoint -> BlockHeader)
-> (Entity Checkpoint -> Checkpoint)
-> Entity Checkpoint
-> BlockHeader
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity Checkpoint -> Checkpoint
forall record. Entity record -> record
entityVal) ([Entity Checkpoint] -> [ChainPoint])
-> ReaderT SqlBackend IO [Entity Checkpoint]
-> ReaderT SqlBackend IO [ChainPoint]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Filter Checkpoint]
-> [SelectOpt Checkpoint]
-> ReaderT SqlBackend IO [Entity Checkpoint]
forall record backend (m :: * -> *).
(MonadIO m, PersistQueryRead backend,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m [Entity record]
selectList
                [ EntityField Checkpoint WalletId
forall typ. (typ ~ WalletId) => EntityField Checkpoint typ
CheckpointWalletId EntityField Checkpoint WalletId -> WalletId -> Filter Checkpoint
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. WalletId
wid ]
                [ EntityField Checkpoint SlotNo -> SelectOpt Checkpoint
forall record typ. EntityField record typ -> SelectOpt record
Asc EntityField Checkpoint SlotNo
forall typ. (typ ~ SlotNo) => EntityField Checkpoint typ
CheckpointSlot ]

        , rollbackTo :: WalletId
-> Slot -> ExceptT ErrNoSuchWallet (SqlPersistT IO) ChainPoint
rollbackTo = \WalletId
wid Slot
requestedPoint -> do
            Maybe (WalletCheckpoint s)
mNearestCheckpoint <-  SqlPersistT
  IO (Either ErrNoSuchWallet (Maybe (WalletCheckpoint s)))
-> ExceptT
     ErrNoSuchWallet (SqlPersistT IO) (Maybe (WalletCheckpoint s))
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (SqlPersistT
   IO (Either ErrNoSuchWallet (Maybe (WalletCheckpoint s)))
 -> ExceptT
      ErrNoSuchWallet (SqlPersistT IO) (Maybe (WalletCheckpoint s)))
-> SqlPersistT
     IO (Either ErrNoSuchWallet (Maybe (WalletCheckpoint s)))
-> ExceptT
     ErrNoSuchWallet (SqlPersistT IO) (Maybe (WalletCheckpoint s))
forall a b. (a -> b) -> a -> b
$ do
                DBVar (SqlPersistT IO) (DeltaMap WalletId (DeltaWalletState s))
-> (Map WalletId (WalletState s)
    -> (Maybe (DeltaMap WalletId (DeltaWalletState s)),
        Either ErrNoSuchWallet (Maybe (WalletCheckpoint s))))
-> SqlPersistT
     IO (Either ErrNoSuchWallet (Maybe (WalletCheckpoint s)))
forall da (m :: * -> *) a b.
(Delta da, Monad m, a ~ Base da) =>
DBVar m da -> (a -> (Maybe da, b)) -> m b
modifyDBMaybe DBVar (SqlPersistT IO) (DeltaMap WalletId (DeltaWalletState s))
walletsDB_ ((Map WalletId (WalletState s)
  -> (Maybe (DeltaMap WalletId (DeltaWalletState s)),
      Either ErrNoSuchWallet (Maybe (WalletCheckpoint s))))
 -> SqlPersistT
      IO (Either ErrNoSuchWallet (Maybe (WalletCheckpoint s))))
-> (Map WalletId (WalletState s)
    -> (Maybe (DeltaMap WalletId (DeltaWalletState s)),
        Either ErrNoSuchWallet (Maybe (WalletCheckpoint s))))
-> SqlPersistT
     IO (Either ErrNoSuchWallet (Maybe (WalletCheckpoint s)))
forall a b. (a -> b) -> a -> b
$ \Map WalletId (WalletState s)
ws ->
                    case WalletId -> Map WalletId (WalletState s) -> Maybe (WalletState s)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup WalletId
wid Map WalletId (WalletState s)
ws of
                        Maybe (WalletState s)
Nothing  -> (Maybe (DeltaMap WalletId (DeltaWalletState s))
forall a. Maybe a
Nothing, Maybe (WalletCheckpoint s)
-> Either ErrNoSuchWallet (Maybe (WalletCheckpoint s))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (WalletCheckpoint s)
forall a. Maybe a
Nothing)
                        Just WalletState s
wal -> case WalletState s -> Slot -> Maybe Slot
forall s. WalletState s -> Slot -> Maybe Slot
findNearestPoint WalletState s
wal Slot
requestedPoint of
                            Maybe Slot
Nothing ->
                                ( Maybe (DeltaMap WalletId (DeltaWalletState s))
forall a. Maybe a
Nothing
                                , ErrRollbackTo
-> Either ErrNoSuchWallet (Maybe (WalletCheckpoint s))
forall a e. Exception e => e -> a
throw (ErrRollbackTo
 -> Either ErrNoSuchWallet (Maybe (WalletCheckpoint s)))
-> ErrRollbackTo
-> Either ErrNoSuchWallet (Maybe (WalletCheckpoint s))
forall a b. (a -> b) -> a -> b
$ WalletId -> Slot -> ErrRollbackTo
ErrNoOlderCheckpoint WalletId
wid Slot
requestedPoint
                                )
                            Just Slot
nearestPoint ->
                                ( DeltaMap WalletId (DeltaWalletState s)
-> Maybe (DeltaMap WalletId (DeltaWalletState s))
forall a. a -> Maybe a
Just (DeltaMap WalletId (DeltaWalletState s)
 -> Maybe (DeltaMap WalletId (DeltaWalletState s)))
-> DeltaMap WalletId (DeltaWalletState s)
-> Maybe (DeltaMap WalletId (DeltaWalletState s))
forall a b. (a -> b) -> a -> b
$ WalletId
-> DeltaWalletState s -> DeltaMap WalletId (DeltaWalletState s)
forall key da. key -> da -> DeltaMap key da
Adjust WalletId
wid
                                    [ DeltasCheckpoints (WalletCheckpoint s) -> DeltaWalletState1 s
forall s.
DeltasCheckpoints (WalletCheckpoint s) -> DeltaWalletState1 s
UpdateCheckpoints [ Slot -> DeltaCheckpoints (WalletCheckpoint s)
forall a. Slot -> DeltaCheckpoints a
RollbackTo Slot
nearestPoint ] ]
                                , Maybe (WalletCheckpoint s)
-> Either ErrNoSuchWallet (Maybe (WalletCheckpoint s))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (WalletCheckpoint s)
 -> Either ErrNoSuchWallet (Maybe (WalletCheckpoint s)))
-> Maybe (WalletCheckpoint s)
-> Either ErrNoSuchWallet (Maybe (WalletCheckpoint s))
forall a b. (a -> b) -> a -> b
$ Slot -> Map Slot (WalletCheckpoint s) -> Maybe (WalletCheckpoint s)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Slot
nearestPoint (Map Slot (WalletCheckpoint s) -> Maybe (WalletCheckpoint s))
-> Map Slot (WalletCheckpoint s) -> Maybe (WalletCheckpoint s)
forall a b. (a -> b) -> a -> b
$
                                    WalletState s
wal WalletState s
-> ((Map Slot (WalletCheckpoint s)
     -> Const
          (Map Slot (WalletCheckpoint s)) (Map Slot (WalletCheckpoint s)))
    -> WalletState s
    -> Const (Map Slot (WalletCheckpoint s)) (WalletState s))
-> Map Slot (WalletCheckpoint s)
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "checkpoints"
  ((Checkpoints (WalletCheckpoint s)
    -> Const
         (Map Slot (WalletCheckpoint s)) (Checkpoints (WalletCheckpoint s)))
   -> WalletState s
   -> Const (Map Slot (WalletCheckpoint s)) (WalletState s))
(Checkpoints (WalletCheckpoint s)
 -> Const
      (Map Slot (WalletCheckpoint s)) (Checkpoints (WalletCheckpoint s)))
-> WalletState s
-> Const (Map Slot (WalletCheckpoint s)) (WalletState s)
#checkpoints ((Checkpoints (WalletCheckpoint s)
  -> Const
       (Map Slot (WalletCheckpoint s)) (Checkpoints (WalletCheckpoint s)))
 -> WalletState s
 -> Const (Map Slot (WalletCheckpoint s)) (WalletState s))
-> ((Map Slot (WalletCheckpoint s)
     -> Const
          (Map Slot (WalletCheckpoint s)) (Map Slot (WalletCheckpoint s)))
    -> Checkpoints (WalletCheckpoint s)
    -> Const
         (Map Slot (WalletCheckpoint s)) (Checkpoints (WalletCheckpoint s)))
-> (Map Slot (WalletCheckpoint s)
    -> Const
         (Map Slot (WalletCheckpoint s)) (Map Slot (WalletCheckpoint s)))
-> WalletState s
-> Const (Map Slot (WalletCheckpoint s)) (WalletState s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IsLabel
  "checkpoints"
  ((Map Slot (WalletCheckpoint s)
    -> Const
         (Map Slot (WalletCheckpoint s)) (Map Slot (WalletCheckpoint s)))
   -> Checkpoints (WalletCheckpoint s)
   -> Const
        (Map Slot (WalletCheckpoint s)) (Checkpoints (WalletCheckpoint s)))
(Map Slot (WalletCheckpoint s)
 -> Const
      (Map Slot (WalletCheckpoint s)) (Map Slot (WalletCheckpoint s)))
-> Checkpoints (WalletCheckpoint s)
-> Const
     (Map Slot (WalletCheckpoint s)) (Checkpoints (WalletCheckpoint s))
#checkpoints
                                )

            case Maybe (WalletCheckpoint s)
mNearestCheckpoint of
                Maybe (WalletCheckpoint s)
Nothing  -> ReaderT SqlBackend IO (Either ErrNoSuchWallet ChainPoint)
-> ExceptT ErrNoSuchWallet (SqlPersistT IO) ChainPoint
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT SqlBackend IO (Either ErrNoSuchWallet ChainPoint)
 -> ExceptT ErrNoSuchWallet (SqlPersistT IO) ChainPoint)
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ChainPoint)
-> ExceptT ErrNoSuchWallet (SqlPersistT IO) ChainPoint
forall a b. (a -> b) -> a -> b
$ Either ErrNoSuchWallet ChainPoint
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ChainPoint)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrNoSuchWallet ChainPoint
 -> ReaderT SqlBackend IO (Either ErrNoSuchWallet ChainPoint))
-> Either ErrNoSuchWallet ChainPoint
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ChainPoint)
forall a b. (a -> b) -> a -> b
$ ErrNoSuchWallet -> Either ErrNoSuchWallet ChainPoint
forall a b. a -> Either a b
Left (ErrNoSuchWallet -> Either ErrNoSuchWallet ChainPoint)
-> ErrNoSuchWallet -> Either ErrNoSuchWallet ChainPoint
forall a b. (a -> b) -> a -> b
$ WalletId -> ErrNoSuchWallet
ErrNoSuchWallet WalletId
wid
                Just WalletCheckpoint s
wcp -> do
                    let nearestPoint :: SlotNo
nearestPoint = WalletCheckpoint s
wcp WalletCheckpoint s
-> ((SlotNo -> Const SlotNo SlotNo)
    -> WalletCheckpoint s -> Const SlotNo (WalletCheckpoint s))
-> SlotNo
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "currentTip"
  ((BlockHeader -> Const SlotNo BlockHeader)
   -> WalletCheckpoint s -> Const SlotNo (WalletCheckpoint s))
(BlockHeader -> Const SlotNo BlockHeader)
-> WalletCheckpoint s -> Const SlotNo (WalletCheckpoint s)
#currentTip ((BlockHeader -> Const SlotNo BlockHeader)
 -> WalletCheckpoint s -> Const SlotNo (WalletCheckpoint s))
-> ((SlotNo -> Const SlotNo SlotNo)
    -> BlockHeader -> Const SlotNo BlockHeader)
-> (SlotNo -> Const SlotNo SlotNo)
-> WalletCheckpoint s
-> Const SlotNo (WalletCheckpoint s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IsLabel
  "slotNo"
  ((SlotNo -> Const SlotNo SlotNo)
   -> BlockHeader -> Const SlotNo BlockHeader)
(SlotNo -> Const SlotNo SlotNo)
-> BlockHeader -> Const SlotNo BlockHeader
#slotNo
                    SqlPersistT IO () -> ExceptT ErrNoSuchWallet (SqlPersistT IO) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (SqlPersistT IO () -> ExceptT ErrNoSuchWallet (SqlPersistT IO) ())
-> SqlPersistT IO () -> ExceptT ErrNoSuchWallet (SqlPersistT IO) ()
forall a b. (a -> b) -> a -> b
$ WalletId -> [Filter DelegationCertificate] -> SqlPersistT IO ()
deleteDelegationCertificates WalletId
wid
                        [ EntityField DelegationCertificate SlotNo
forall typ. (typ ~ SlotNo) => EntityField DelegationCertificate typ
CertSlot EntityField DelegationCertificate SlotNo
-> SlotNo -> Filter DelegationCertificate
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
>. SlotNo
nearestPoint
                        ]
                    SqlPersistT IO () -> ExceptT ErrNoSuchWallet (SqlPersistT IO) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (SqlPersistT IO () -> ExceptT ErrNoSuchWallet (SqlPersistT IO) ())
-> SqlPersistT IO () -> ExceptT ErrNoSuchWallet (SqlPersistT IO) ()
forall a b. (a -> b) -> a -> b
$ WalletId -> [Filter StakeKeyCertificate] -> SqlPersistT IO ()
deleteStakeKeyCerts WalletId
wid
                        [ EntityField StakeKeyCertificate SlotNo
forall typ. (typ ~ SlotNo) => EntityField StakeKeyCertificate typ
StakeKeyCertSlot EntityField StakeKeyCertificate SlotNo
-> SlotNo -> Filter StakeKeyCertificate
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
>. SlotNo
nearestPoint
                        ]
                    ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
-> ExceptT ErrNoSuchWallet (SqlPersistT IO) ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
 -> ExceptT ErrNoSuchWallet (SqlPersistT IO) ())
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
-> ExceptT ErrNoSuchWallet (SqlPersistT IO) ()
forall a b. (a -> b) -> a -> b
$ DBVar (SqlPersistT IO) DeltaTxWalletsHistory
-> ((TxHistory, Map WalletId TxMetaHistory)
    -> (Maybe DeltaTxWalletsHistory, Either ErrNoSuchWallet ()))
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall da (m :: * -> *) a b.
(Delta da, Monad m, a ~ Base da) =>
DBVar m da -> (a -> (Maybe da, b)) -> m b
modifyDBMaybe DBVar (SqlPersistT IO) DeltaTxWalletsHistory
transactionsDBVar (((TxHistory, Map WalletId TxMetaHistory)
  -> (Maybe DeltaTxWalletsHistory, Either ErrNoSuchWallet ()))
 -> ReaderT SqlBackend IO (Either ErrNoSuchWallet ()))
-> ((TxHistory, Map WalletId TxMetaHistory)
    -> (Maybe DeltaTxWalletsHistory, Either ErrNoSuchWallet ()))
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall a b. (a -> b) -> a -> b
$ \(TxHistory, Map WalletId TxMetaHistory)
_ ->
                        let
                            delta :: Maybe DeltaTxWalletsHistory
delta = DeltaTxWalletsHistory -> Maybe DeltaTxWalletsHistory
forall a. a -> Maybe a
Just
                                (DeltaTxWalletsHistory -> Maybe DeltaTxWalletsHistory)
-> DeltaTxWalletsHistory -> Maybe DeltaTxWalletsHistory
forall a b. (a -> b) -> a -> b
$ WalletId -> ManipulateTxMetaHistory -> DeltaTxWalletsHistory
ChangeTxMetaWalletsHistory WalletId
wid
                                (ManipulateTxMetaHistory -> DeltaTxWalletsHistory)
-> ManipulateTxMetaHistory -> DeltaTxWalletsHistory
forall a b. (a -> b) -> a -> b
$ SlotNo -> ManipulateTxMetaHistory
RollBackTxMetaHistory SlotNo
nearestPoint
                        in  (Maybe DeltaTxWalletsHistory
delta, () -> Either ErrNoSuchWallet ()
forall a b. b -> Either a b
Right ())
                    ChainPoint -> ExceptT ErrNoSuchWallet (SqlPersistT IO) ChainPoint
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                        (ChainPoint -> ExceptT ErrNoSuchWallet (SqlPersistT IO) ChainPoint)
-> ChainPoint
-> ExceptT ErrNoSuchWallet (SqlPersistT IO) ChainPoint
forall a b. (a -> b) -> a -> b
$ BlockHeader -> ChainPoint
W.chainPointFromBlockHeader
                        (BlockHeader -> ChainPoint) -> BlockHeader -> ChainPoint
forall a b. (a -> b) -> a -> b
$ ((BlockHeader -> Const BlockHeader BlockHeader)
 -> WalletCheckpoint s -> Const BlockHeader (WalletCheckpoint s))
-> WalletCheckpoint s -> BlockHeader
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "currentTip"
  ((BlockHeader -> Const BlockHeader BlockHeader)
   -> WalletCheckpoint s -> Const BlockHeader (WalletCheckpoint s))
(BlockHeader -> Const BlockHeader BlockHeader)
-> WalletCheckpoint s -> Const BlockHeader (WalletCheckpoint s)
#currentTip WalletCheckpoint s
wcp

        , prune :: WalletId
-> Quantity "block" Word32
-> ExceptT ErrNoSuchWallet (SqlPersistT IO) ()
prune = \WalletId
wid Quantity "block" Word32
epochStability -> do
            ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
-> ExceptT ErrNoSuchWallet (SqlPersistT IO) ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
 -> ExceptT ErrNoSuchWallet (SqlPersistT IO) ())
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
-> ExceptT ErrNoSuchWallet (SqlPersistT IO) ()
forall a b. (a -> b) -> a -> b
$ do
                WalletId -> SqlPersistT IO (Maybe (Wallet s))
readCheckpoint_ WalletId
wid SqlPersistT IO (Maybe (Wallet s))
-> (Maybe (Wallet s)
    -> ReaderT SqlBackend IO (Either ErrNoSuchWallet ()))
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                    Maybe (Wallet s)
Nothing -> Either ErrNoSuchWallet ()
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrNoSuchWallet ()
 -> ReaderT SqlBackend IO (Either ErrNoSuchWallet ()))
-> Either ErrNoSuchWallet ()
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall a b. (a -> b) -> a -> b
$ ErrNoSuchWallet -> Either ErrNoSuchWallet ()
forall a b. a -> Either a b
Left (ErrNoSuchWallet -> Either ErrNoSuchWallet ())
-> ErrNoSuchWallet -> Either ErrNoSuchWallet ()
forall a b. (a -> b) -> a -> b
$ WalletId -> ErrNoSuchWallet
ErrNoSuchWallet WalletId
wid
                    Just Wallet s
cp -> () -> Either ErrNoSuchWallet ()
forall a b. b -> Either a b
Right (() -> Either ErrNoSuchWallet ())
-> SqlPersistT IO ()
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
                        let tip :: BlockHeader
tip = Wallet s
cp Wallet s
-> ((BlockHeader -> Const BlockHeader BlockHeader)
    -> Wallet s -> Const BlockHeader (Wallet s))
-> BlockHeader
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "currentTip"
  ((BlockHeader -> Const BlockHeader BlockHeader)
   -> Wallet s -> Const BlockHeader (Wallet s))
(BlockHeader -> Const BlockHeader BlockHeader)
-> Wallet s -> Const BlockHeader (Wallet s)
#currentTip
                        WalletId
-> Quantity "block" Word32 -> BlockHeader -> SqlPersistT IO ()
pruneCheckpoints WalletId
wid Quantity "block" Word32
epochStability BlockHeader
tip
                        WalletId
-> Quantity "block" Word32 -> BlockHeader -> SqlPersistT IO ()
pruneLocalTxSubmission WalletId
wid Quantity "block" Word32
epochStability BlockHeader
tip
            SqlPersistT IO () -> ExceptT ErrNoSuchWallet (SqlPersistT IO) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (SqlPersistT IO () -> ExceptT ErrNoSuchWallet (SqlPersistT IO) ())
-> SqlPersistT IO () -> ExceptT ErrNoSuchWallet (SqlPersistT IO) ()
forall a b. (a -> b) -> a -> b
$ DBVar (SqlPersistT IO) DeltaTxWalletsHistory
-> ((TxHistory, Map WalletId TxMetaHistory)
    -> (Maybe DeltaTxWalletsHistory, ()))
-> SqlPersistT IO ()
forall da (m :: * -> *) a b.
(Delta da, Monad m, a ~ Base da) =>
DBVar m da -> (a -> (Maybe da, b)) -> m b
modifyDBMaybe DBVar (SqlPersistT IO) DeltaTxWalletsHistory
transactionsDBVar (((TxHistory, Map WalletId TxMetaHistory)
  -> (Maybe DeltaTxWalletsHistory, ()))
 -> SqlPersistT IO ())
-> ((TxHistory, Map WalletId TxMetaHistory)
    -> (Maybe DeltaTxWalletsHistory, ()))
-> SqlPersistT IO ()
forall a b. (a -> b) -> a -> b
$ \(TxHistory, Map WalletId TxMetaHistory)
_ ->
                (DeltaTxWalletsHistory -> Maybe DeltaTxWalletsHistory
forall a. a -> Maybe a
Just DeltaTxWalletsHistory
GarbageCollectTxWalletsHistory, ())

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

        , putWalletMeta :: WalletId
-> WalletMetadata -> ExceptT ErrNoSuchWallet (SqlPersistT IO) ()
putWalletMeta = \WalletId
wid WalletMetadata
meta -> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
-> ExceptT ErrNoSuchWallet (SqlPersistT IO) ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
 -> ExceptT ErrNoSuchWallet (SqlPersistT IO) ())
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
-> ExceptT ErrNoSuchWallet (SqlPersistT IO) ()
forall a b. (a -> b) -> a -> b
$ do
            WalletId -> SqlPersistT IO (Maybe Wallet)
forall (m :: * -> *).
MonadIO m =>
WalletId -> SqlPersistT m (Maybe Wallet)
selectWallet WalletId
wid SqlPersistT IO (Maybe Wallet)
-> (Maybe Wallet
    -> ReaderT SqlBackend IO (Either ErrNoSuchWallet ()))
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Maybe Wallet
Nothing -> Either ErrNoSuchWallet ()
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrNoSuchWallet ()
 -> ReaderT SqlBackend IO (Either ErrNoSuchWallet ()))
-> Either ErrNoSuchWallet ()
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall a b. (a -> b) -> a -> b
$ ErrNoSuchWallet -> Either ErrNoSuchWallet ()
forall a b. a -> Either a b
Left (ErrNoSuchWallet -> Either ErrNoSuchWallet ())
-> ErrNoSuchWallet -> Either ErrNoSuchWallet ()
forall a b. (a -> b) -> a -> b
$ WalletId -> ErrNoSuchWallet
ErrNoSuchWallet WalletId
wid
                Just Wallet
_ -> do
                    [Filter Wallet] -> [Update Wallet] -> SqlPersistT IO ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> [Update record] -> ReaderT backend m ()
updateWhere [EntityField Wallet WalletId
forall typ. (typ ~ WalletId) => EntityField Wallet typ
WalId EntityField Wallet WalletId -> WalletId -> Filter Wallet
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. WalletId
wid]
                        (WalletMetadata -> [Update Wallet]
mkWalletMetadataUpdate WalletMetadata
meta)
                    Either ErrNoSuchWallet ()
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrNoSuchWallet ()
 -> ReaderT SqlBackend IO (Either ErrNoSuchWallet ()))
-> Either ErrNoSuchWallet ()
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall a b. (a -> b) -> a -> b
$ () -> Either ErrNoSuchWallet ()
forall a b. b -> Either a b
Right ()

        , readWalletMeta :: WalletId -> ReaderT SqlBackend IO (Maybe WalletMetadata)
readWalletMeta = \WalletId
wid -> do
            WalletId -> SqlPersistT IO (Maybe (Wallet s))
readCheckpoint_ WalletId
wid SqlPersistT IO (Maybe (Wallet s))
-> (Maybe (Wallet s)
    -> ReaderT SqlBackend IO (Maybe WalletMetadata))
-> ReaderT SqlBackend IO (Maybe WalletMetadata)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Maybe (Wallet s)
Nothing -> Maybe WalletMetadata
-> ReaderT SqlBackend IO (Maybe WalletMetadata)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe WalletMetadata
forall a. Maybe a
Nothing
                Just Wallet s
cp -> do
                    EpochNo
currentEpoch <- IO EpochNo -> ReaderT SqlBackend IO EpochNo
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO EpochNo -> ReaderT SqlBackend IO EpochNo)
-> IO EpochNo -> ReaderT SqlBackend IO EpochNo
forall a b. (a -> b) -> a -> b
$
                        TimeInterpreter IO -> Qry EpochNo -> IO EpochNo
forall (m :: * -> *) a.
(HasCallStack, Monad m) =>
TimeInterpreter m -> Qry a -> m a
interpretQuery TimeInterpreter IO
ti (SlotNo -> Qry EpochNo
epochOf (SlotNo -> Qry EpochNo) -> SlotNo -> Qry EpochNo
forall a b. (a -> b) -> a -> b
$ Wallet s
cp Wallet s
-> ((SlotNo -> Const SlotNo SlotNo)
    -> Wallet s -> Const SlotNo (Wallet s))
-> SlotNo
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "currentTip"
  ((BlockHeader -> Const SlotNo BlockHeader)
   -> Wallet s -> Const SlotNo (Wallet s))
(BlockHeader -> Const SlotNo BlockHeader)
-> Wallet s -> Const SlotNo (Wallet s)
#currentTip ((BlockHeader -> Const SlotNo BlockHeader)
 -> Wallet s -> Const SlotNo (Wallet s))
-> ((SlotNo -> Const SlotNo SlotNo)
    -> BlockHeader -> Const SlotNo BlockHeader)
-> (SlotNo -> Const SlotNo SlotNo)
-> Wallet s
-> Const SlotNo (Wallet s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IsLabel
  "slotNo"
  ((SlotNo -> Const SlotNo SlotNo)
   -> BlockHeader -> Const SlotNo BlockHeader)
(SlotNo -> Const SlotNo SlotNo)
-> BlockHeader -> Const SlotNo BlockHeader
#slotNo)
                    TimeInterpreter IO
-> WalletId -> EpochNo -> SqlPersistT IO WalletDelegation
readWalletDelegation TimeInterpreter IO
ti WalletId
wid EpochNo
currentEpoch
                        SqlPersistT IO WalletDelegation
-> (WalletDelegation
    -> ReaderT SqlBackend IO (Maybe WalletMetadata))
-> ReaderT SqlBackend IO (Maybe WalletMetadata)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= WalletId
-> WalletDelegation -> ReaderT SqlBackend IO (Maybe WalletMetadata)
readWalletMetadata WalletId
wid

        , putDelegationCertificate :: WalletId
-> DelegationCertificate
-> SlotNo
-> ExceptT ErrNoSuchWallet (SqlPersistT IO) ()
putDelegationCertificate = \WalletId
wid DelegationCertificate
cert SlotNo
sl -> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
-> ExceptT ErrNoSuchWallet (SqlPersistT IO) ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
 -> ExceptT ErrNoSuchWallet (SqlPersistT IO) ())
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
-> ExceptT ErrNoSuchWallet (SqlPersistT IO) ()
forall a b. (a -> b) -> a -> b
$ do
            WalletId -> SqlPersistT IO (Maybe Wallet)
forall (m :: * -> *).
MonadIO m =>
WalletId -> SqlPersistT m (Maybe Wallet)
selectWallet WalletId
wid SqlPersistT IO (Maybe Wallet)
-> (Maybe Wallet
    -> ReaderT SqlBackend IO (Either ErrNoSuchWallet ()))
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Maybe Wallet
Nothing -> Either ErrNoSuchWallet ()
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrNoSuchWallet ()
 -> ReaderT SqlBackend IO (Either ErrNoSuchWallet ()))
-> Either ErrNoSuchWallet ()
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall a b. (a -> b) -> a -> b
$ ErrNoSuchWallet -> Either ErrNoSuchWallet ()
forall a b. a -> Either a b
Left (ErrNoSuchWallet -> Either ErrNoSuchWallet ())
-> ErrNoSuchWallet -> Either ErrNoSuchWallet ()
forall a b. (a -> b) -> a -> b
$ WalletId -> ErrNoSuchWallet
ErrNoSuchWallet WalletId
wid
                Just Wallet
_  -> case DelegationCertificate
cert of
                    W.CertDelegateNone RewardAccount
_ -> do
                        Key DelegationCertificate
-> DelegationCertificate -> SqlPersistT IO ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> record -> ReaderT backend m ()
repsert
                            (WalletId -> SlotNo -> Key DelegationCertificate
DelegationCertificateKey WalletId
wid SlotNo
sl)
                            (WalletId -> SlotNo -> Maybe PoolId -> DelegationCertificate
DelegationCertificate WalletId
wid SlotNo
sl Maybe PoolId
forall a. Maybe a
Nothing)
                        () -> Either ErrNoSuchWallet ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Either ErrNoSuchWallet ())
-> SqlPersistT IO ()
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Key StakeKeyCertificate -> StakeKeyCertificate -> SqlPersistT IO ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> record -> ReaderT backend m ()
repsert
                            (WalletId -> SlotNo -> Key StakeKeyCertificate
StakeKeyCertificateKey WalletId
wid SlotNo
sl)
                            (WalletId -> SlotNo -> StakeKeyCertificate -> StakeKeyCertificate
StakeKeyCertificate WalletId
wid SlotNo
sl StakeKeyCertificate
W.StakeKeyDeregistration)
                    W.CertDelegateFull RewardAccount
_ PoolId
pool ->
                        () -> Either ErrNoSuchWallet ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Either ErrNoSuchWallet ())
-> SqlPersistT IO ()
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Key DelegationCertificate
-> DelegationCertificate -> SqlPersistT IO ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> record -> ReaderT backend m ()
repsert
                            (WalletId -> SlotNo -> Key DelegationCertificate
DelegationCertificateKey WalletId
wid SlotNo
sl)
                            (WalletId -> SlotNo -> Maybe PoolId -> DelegationCertificate
DelegationCertificate WalletId
wid SlotNo
sl (PoolId -> Maybe PoolId
forall a. a -> Maybe a
Just PoolId
pool))
                    W.CertRegisterKey RewardAccount
_ ->
                        () -> Either ErrNoSuchWallet ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Either ErrNoSuchWallet ())
-> SqlPersistT IO ()
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Key StakeKeyCertificate -> StakeKeyCertificate -> SqlPersistT IO ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> record -> ReaderT backend m ()
repsert
                            (WalletId -> SlotNo -> Key StakeKeyCertificate
StakeKeyCertificateKey WalletId
wid SlotNo
sl)
                            (WalletId -> SlotNo -> StakeKeyCertificate -> StakeKeyCertificate
StakeKeyCertificate WalletId
wid SlotNo
sl StakeKeyCertificate
W.StakeKeyRegistration)

        , isStakeKeyRegistered :: WalletId -> ExceptT ErrNoSuchWallet (SqlPersistT IO) Bool
isStakeKeyRegistered = \WalletId
wid -> ReaderT SqlBackend IO (Either ErrNoSuchWallet Bool)
-> ExceptT ErrNoSuchWallet (SqlPersistT IO) Bool
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT SqlBackend IO (Either ErrNoSuchWallet Bool)
 -> ExceptT ErrNoSuchWallet (SqlPersistT IO) Bool)
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet Bool)
-> ExceptT ErrNoSuchWallet (SqlPersistT IO) Bool
forall a b. (a -> b) -> a -> b
$ do
              WalletId -> SqlPersistT IO (Maybe Wallet)
forall (m :: * -> *).
MonadIO m =>
WalletId -> SqlPersistT m (Maybe Wallet)
selectWallet WalletId
wid SqlPersistT IO (Maybe Wallet)
-> (Maybe Wallet
    -> ReaderT SqlBackend IO (Either ErrNoSuchWallet Bool))
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet Bool)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Maybe Wallet
Nothing -> Either ErrNoSuchWallet Bool
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrNoSuchWallet Bool
 -> ReaderT SqlBackend IO (Either ErrNoSuchWallet Bool))
-> Either ErrNoSuchWallet Bool
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet Bool)
forall a b. (a -> b) -> a -> b
$ ErrNoSuchWallet -> Either ErrNoSuchWallet Bool
forall a b. a -> Either a b
Left (ErrNoSuchWallet -> Either ErrNoSuchWallet Bool)
-> ErrNoSuchWallet -> Either ErrNoSuchWallet Bool
forall a b. (a -> b) -> a -> b
$ WalletId -> ErrNoSuchWallet
ErrNoSuchWallet WalletId
wid
                Just{} -> do
                    Maybe StakeKeyCertificate
val <- (Entity StakeKeyCertificate -> StakeKeyCertificate)
-> Maybe (Entity StakeKeyCertificate) -> Maybe StakeKeyCertificate
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Entity StakeKeyCertificate -> StakeKeyCertificate
forall record. Entity record -> record
entityVal (Maybe (Entity StakeKeyCertificate) -> Maybe StakeKeyCertificate)
-> ReaderT SqlBackend IO (Maybe (Entity StakeKeyCertificate))
-> ReaderT SqlBackend IO (Maybe StakeKeyCertificate)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Filter StakeKeyCertificate]
-> [SelectOpt StakeKeyCertificate]
-> ReaderT SqlBackend IO (Maybe (Entity StakeKeyCertificate))
forall backend (m :: * -> *) record.
(PersistQueryRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m (Maybe (Entity record))
selectFirst
                        [EntityField StakeKeyCertificate WalletId
forall typ. (typ ~ WalletId) => EntityField StakeKeyCertificate typ
StakeKeyCertWalletId EntityField StakeKeyCertificate WalletId
-> WalletId -> Filter StakeKeyCertificate
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. WalletId
wid]
                        [EntityField StakeKeyCertificate SlotNo
-> SelectOpt StakeKeyCertificate
forall record typ. EntityField record typ -> SelectOpt record
Desc EntityField StakeKeyCertificate SlotNo
forall typ. (typ ~ SlotNo) => EntityField StakeKeyCertificate typ
StakeKeyCertSlot]
                    Either ErrNoSuchWallet Bool
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ErrNoSuchWallet Bool
 -> ReaderT SqlBackend IO (Either ErrNoSuchWallet Bool))
-> Either ErrNoSuchWallet Bool
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet Bool)
forall a b. (a -> b) -> a -> b
$ case Maybe StakeKeyCertificate
val of
                        Maybe StakeKeyCertificate
Nothing -> Bool -> Either ErrNoSuchWallet Bool
forall a b. b -> Either a b
Right Bool
False
                        Just (StakeKeyCertificate WalletId
_ SlotNo
_ StakeKeyCertificate
status) ->
                            Bool -> Either ErrNoSuchWallet Bool
forall a b. b -> Either a b
Right (StakeKeyCertificate
status StakeKeyCertificate -> StakeKeyCertificate -> Bool
forall a. Eq a => a -> a -> Bool
== StakeKeyCertificate
W.StakeKeyRegistration)

        {-----------------------------------------------------------------------
                                     Tx History
        -----------------------------------------------------------------------}
        , putTxHistory :: WalletId
-> [(Tx, TxMeta)] -> ExceptT ErrNoSuchWallet (SqlPersistT IO) ()
putTxHistory = \WalletId
wid [(Tx, TxMeta)]
txs -> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
-> ExceptT ErrNoSuchWallet (SqlPersistT IO) ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
 -> ExceptT ErrNoSuchWallet (SqlPersistT IO) ())
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
-> ExceptT ErrNoSuchWallet (SqlPersistT IO) ()
forall a b. (a -> b) -> a -> b
$ do
            WalletId -> SqlPersistT IO (Maybe Wallet)
forall (m :: * -> *).
MonadIO m =>
WalletId -> SqlPersistT m (Maybe Wallet)
selectWallet WalletId
wid SqlPersistT IO (Maybe Wallet)
-> (Maybe Wallet
    -> ReaderT SqlBackend IO (Either ErrNoSuchWallet ()))
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Maybe Wallet
Nothing -> Either ErrNoSuchWallet ()
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrNoSuchWallet ()
 -> ReaderT SqlBackend IO (Either ErrNoSuchWallet ()))
-> Either ErrNoSuchWallet ()
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall a b. (a -> b) -> a -> b
$ ErrNoSuchWallet -> Either ErrNoSuchWallet ()
forall a b. a -> Either a b
Left (ErrNoSuchWallet -> Either ErrNoSuchWallet ())
-> ErrNoSuchWallet -> Either ErrNoSuchWallet ()
forall a b. (a -> b) -> a -> b
$ WalletId -> ErrNoSuchWallet
ErrNoSuchWallet WalletId
wid
                Just Wallet
_ -> DBVar (SqlPersistT IO) DeltaTxWalletsHistory
-> ((TxHistory, Map WalletId TxMetaHistory)
    -> (Maybe DeltaTxWalletsHistory, Either ErrNoSuchWallet ()))
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall da (m :: * -> *) a b.
(Delta da, Monad m, a ~ Base da) =>
DBVar m da -> (a -> (Maybe da, b)) -> m b
modifyDBMaybe DBVar (SqlPersistT IO) DeltaTxWalletsHistory
transactionsDBVar (((TxHistory, Map WalletId TxMetaHistory)
  -> (Maybe DeltaTxWalletsHistory, Either ErrNoSuchWallet ()))
 -> ReaderT SqlBackend IO (Either ErrNoSuchWallet ()))
-> ((TxHistory, Map WalletId TxMetaHistory)
    -> (Maybe DeltaTxWalletsHistory, Either ErrNoSuchWallet ()))
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall a b. (a -> b) -> a -> b
$ \(TxHistory, Map WalletId TxMetaHistory)
_ ->
                    let
                        delta :: Maybe DeltaTxWalletsHistory
delta = DeltaTxWalletsHistory -> Maybe DeltaTxWalletsHistory
forall a. a -> Maybe a
Just (DeltaTxWalletsHistory -> Maybe DeltaTxWalletsHistory)
-> DeltaTxWalletsHistory -> Maybe DeltaTxWalletsHistory
forall a b. (a -> b) -> a -> b
$ WalletId -> [(Tx, TxMeta)] -> DeltaTxWalletsHistory
ExpandTxWalletsHistory WalletId
wid [(Tx, TxMeta)]
txs
                    in  (Maybe DeltaTxWalletsHistory
delta, () -> Either ErrNoSuchWallet ()
forall a b. b -> Either a b
Right ())

        , readTxHistory :: WalletId
-> Maybe Coin
-> SortOrder
-> Range SlotNo
-> Maybe TxStatus
-> ReaderT SqlBackend IO [TransactionInfo]
readTxHistory = \WalletId
wid Maybe Coin
minWithdrawal SortOrder
order Range SlotNo
range Maybe TxStatus
status -> do
            WalletId -> SqlPersistT IO (Maybe (Wallet s))
readCheckpoint_ WalletId
wid SqlPersistT IO (Maybe (Wallet s))
-> (Maybe (Wallet s) -> ReaderT SqlBackend IO [TransactionInfo])
-> ReaderT SqlBackend IO [TransactionInfo]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Maybe (Wallet s)
Nothing -> [TransactionInfo] -> ReaderT SqlBackend IO [TransactionInfo]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
                Just Wallet s
cp -> do
                    (TxHistory, Map WalletId TxMetaHistory)
txHistory <- DBVar (SqlPersistT IO) DeltaTxWalletsHistory
-> SqlPersistT IO (TxHistory, Map WalletId TxMetaHistory)
forall da a (m :: * -> *).
(Delta da, a ~ Base da) =>
DBVar m da -> m a
readDBVar DBVar (SqlPersistT IO) DeltaTxWalletsHistory
transactionsDBVar
                    let filtering :: TxMeta -> Bool
filtering DB.TxMeta{Maybe Bool
Maybe Word64
Maybe TxMetadata
Maybe SlotNo
Word32
SlotNo
Coin
Direction
TxStatus
WalletId
TxId
txMetaScriptValidity :: TxMeta -> Maybe Bool
txMetaFee :: TxMeta -> Maybe Word64
txMetaSlotExpires :: TxMeta -> Maybe SlotNo
txMetadata :: TxMeta -> Maybe TxMetadata
txMetaAmount :: TxMeta -> Coin
txMetaBlockHeight :: TxMeta -> Word32
txMetaSlot :: TxMeta -> SlotNo
txMetaDirection :: TxMeta -> Direction
txMetaStatus :: TxMeta -> TxStatus
txMetaWalletId :: TxMeta -> WalletId
txMetaTxId :: TxMeta -> TxId
txMetaScriptValidity :: Maybe Bool
txMetaFee :: Maybe Word64
txMetaSlotExpires :: Maybe SlotNo
txMetadata :: Maybe TxMetadata
txMetaAmount :: Coin
txMetaBlockHeight :: Word32
txMetaSlot :: SlotNo
txMetaDirection :: Direction
txMetaStatus :: TxStatus
txMetaWalletId :: WalletId
txMetaTxId :: TxId
..} = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ [Maybe Bool] -> [Bool]
forall a. [Maybe a] -> [a]
catMaybes
                            [ (SlotNo
txMetaSlot SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
>=) (SlotNo -> Bool) -> Maybe SlotNo -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range SlotNo -> Maybe SlotNo
forall a. Range a -> Maybe a
W.inclusiveLowerBound Range SlotNo
range
                            , (SlotNo
txMetaSlot SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
<=) (SlotNo -> Bool) -> Maybe SlotNo -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range SlotNo -> Maybe SlotNo
forall a. Range a -> Maybe a
W.inclusiveUpperBound Range SlotNo
range
                            , (TxStatus
txMetaStatus TxStatus -> TxStatus -> Bool
forall a. Eq a => a -> a -> Bool
==) (TxStatus -> Bool) -> Maybe TxStatus -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe TxStatus
status
                            ]
                    IO [TransactionInfo] -> ReaderT SqlBackend IO [TransactionInfo]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO [TransactionInfo] -> ReaderT SqlBackend IO [TransactionInfo])
-> IO [TransactionInfo] -> ReaderT SqlBackend IO [TransactionInfo]
forall a b. (a -> b) -> a -> b
$ Wallet s
-> TimeInterpreter IO
-> WalletId
-> Maybe Coin
-> SortOrder
-> (TxMeta -> Bool)
-> (TxHistory, Map WalletId TxMetaHistory)
-> IO [TransactionInfo]
forall (m :: * -> *) s.
Monad m =>
Wallet s
-> TimeInterpreter m
-> WalletId
-> Maybe Coin
-> SortOrder
-> (TxMeta -> Bool)
-> (TxHistory, Map WalletId TxMetaHistory)
-> m [TransactionInfo]
selectTxHistory Wallet s
cp TimeInterpreter IO
ti WalletId
wid Maybe Coin
minWithdrawal
                        SortOrder
order TxMeta -> Bool
filtering (TxHistory, Map WalletId TxMetaHistory)
txHistory

        , putLocalTxSubmission :: WalletId
-> Hash "Tx"
-> SealedTx
-> SlotNo
-> ExceptT ErrPutLocalTxSubmission (SqlPersistT IO) ()
putLocalTxSubmission = \WalletId
wid Hash "Tx"
txid SealedTx
tx SlotNo
sl -> ReaderT SqlBackend IO (Either ErrPutLocalTxSubmission ())
-> ExceptT ErrPutLocalTxSubmission (SqlPersistT IO) ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT SqlBackend IO (Either ErrPutLocalTxSubmission ())
 -> ExceptT ErrPutLocalTxSubmission (SqlPersistT IO) ())
-> ReaderT SqlBackend IO (Either ErrPutLocalTxSubmission ())
-> ExceptT ErrPutLocalTxSubmission (SqlPersistT IO) ()
forall a b. (a -> b) -> a -> b
$ do
            let errNoSuchWallet :: ErrPutLocalTxSubmission
errNoSuchWallet = ErrNoSuchWallet -> ErrPutLocalTxSubmission
ErrPutLocalTxSubmissionNoSuchWallet (ErrNoSuchWallet -> ErrPutLocalTxSubmission)
-> ErrNoSuchWallet -> ErrPutLocalTxSubmission
forall a b. (a -> b) -> a -> b
$
                    WalletId -> ErrNoSuchWallet
ErrNoSuchWallet WalletId
wid
            let errNoSuchTx :: ErrPutLocalTxSubmission
errNoSuchTx = ErrNoSuchTransaction -> ErrPutLocalTxSubmission
ErrPutLocalTxSubmissionNoSuchTransaction (ErrNoSuchTransaction -> ErrPutLocalTxSubmission)
-> ErrNoSuchTransaction -> ErrPutLocalTxSubmission
forall a b. (a -> b) -> a -> b
$
                    WalletId -> Hash "Tx" -> ErrNoSuchTransaction
ErrNoSuchTransaction WalletId
wid Hash "Tx"
txid

            WalletId -> SqlPersistT IO (Maybe Wallet)
forall (m :: * -> *).
MonadIO m =>
WalletId -> SqlPersistT m (Maybe Wallet)
selectWallet WalletId
wid SqlPersistT IO (Maybe Wallet)
-> (Maybe Wallet
    -> ReaderT SqlBackend IO (Either ErrPutLocalTxSubmission ()))
-> ReaderT SqlBackend IO (Either ErrPutLocalTxSubmission ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Maybe Wallet
Nothing -> Either ErrPutLocalTxSubmission ()
-> ReaderT SqlBackend IO (Either ErrPutLocalTxSubmission ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrPutLocalTxSubmission ()
 -> ReaderT SqlBackend IO (Either ErrPutLocalTxSubmission ()))
-> Either ErrPutLocalTxSubmission ()
-> ReaderT SqlBackend IO (Either ErrPutLocalTxSubmission ())
forall a b. (a -> b) -> a -> b
$ ErrPutLocalTxSubmission -> Either ErrPutLocalTxSubmission ()
forall a b. a -> Either a b
Left ErrPutLocalTxSubmission
errNoSuchWallet
                Just Wallet
_ -> ErrPutLocalTxSubmission
-> SqlPersistT IO ()
-> ReaderT SqlBackend IO (Either ErrPutLocalTxSubmission ())
forall (m :: * -> *) e a.
MonadUnliftIO m =>
e -> m a -> m (Either e a)
handleConstraint ErrPutLocalTxSubmission
errNoSuchTx (SqlPersistT IO ()
 -> ReaderT SqlBackend IO (Either ErrPutLocalTxSubmission ()))
-> SqlPersistT IO ()
-> ReaderT SqlBackend IO (Either ErrPutLocalTxSubmission ())
forall a b. (a -> b) -> a -> b
$ do
                    let record :: LocalTxSubmission
record = TxId -> WalletId -> SlotNo -> SealedTx -> LocalTxSubmission
LocalTxSubmission (Hash "Tx" -> TxId
TxId Hash "Tx"
txid) WalletId
wid SlotNo
sl SealedTx
tx
                    ReaderT SqlBackend IO (Entity LocalTxSubmission)
-> SqlPersistT IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT SqlBackend IO (Entity LocalTxSubmission)
 -> SqlPersistT IO ())
-> ReaderT SqlBackend IO (Entity LocalTxSubmission)
-> SqlPersistT IO ()
forall a b. (a -> b) -> a -> b
$ LocalTxSubmission
-> [Update LocalTxSubmission]
-> ReaderT SqlBackend IO (Entity LocalTxSubmission)
forall backend record (m :: * -> *).
(PersistUniqueWrite backend, MonadIO m,
 PersistRecordBackend record backend, OnlyOneUniqueKey record) =>
record -> [Update record] -> ReaderT backend m (Entity record)
upsert LocalTxSubmission
record [ EntityField LocalTxSubmission SlotNo
forall typ. (typ ~ SlotNo) => EntityField LocalTxSubmission typ
LocalTxSubmissionLastSlot EntityField LocalTxSubmission SlotNo
-> SlotNo -> Update LocalTxSubmission
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. SlotNo
sl ]

        , readLocalTxSubmissionPending :: WalletId
-> ReaderT SqlBackend IO [LocalTxSubmissionStatus SealedTx]
readLocalTxSubmissionPending =
            ([(SlotNo, LocalTxSubmission)]
 -> [LocalTxSubmissionStatus SealedTx])
-> ReaderT SqlBackend IO [(SlotNo, LocalTxSubmission)]
-> ReaderT SqlBackend IO [LocalTxSubmissionStatus SealedTx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((SlotNo, LocalTxSubmission) -> LocalTxSubmissionStatus SealedTx)
-> [(SlotNo, LocalTxSubmission)]
-> [LocalTxSubmissionStatus SealedTx]
forall a b. (a -> b) -> [a] -> [b]
map (SlotNo, LocalTxSubmission) -> LocalTxSubmissionStatus SealedTx
localTxSubmissionFromEntity)
            (ReaderT SqlBackend IO [(SlotNo, LocalTxSubmission)]
 -> ReaderT SqlBackend IO [LocalTxSubmissionStatus SealedTx])
-> (WalletId
    -> ReaderT SqlBackend IO [(SlotNo, LocalTxSubmission)])
-> WalletId
-> ReaderT SqlBackend IO [LocalTxSubmissionStatus SealedTx]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WalletId -> ReaderT SqlBackend IO [(SlotNo, LocalTxSubmission)]
listPendingLocalTxSubmissionQuery

        , updatePendingTxForExpiry :: WalletId -> SlotNo -> ExceptT ErrNoSuchWallet (SqlPersistT IO) ()
updatePendingTxForExpiry = \WalletId
wid SlotNo
tip -> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
-> ExceptT ErrNoSuchWallet (SqlPersistT IO) ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
 -> ExceptT ErrNoSuchWallet (SqlPersistT IO) ())
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
-> ExceptT ErrNoSuchWallet (SqlPersistT IO) ()
forall a b. (a -> b) -> a -> b
$
            WalletId -> SqlPersistT IO (Maybe Wallet)
forall (m :: * -> *).
MonadIO m =>
WalletId -> SqlPersistT m (Maybe Wallet)
selectWallet WalletId
wid SqlPersistT IO (Maybe Wallet)
-> (Maybe Wallet
    -> ReaderT SqlBackend IO (Either ErrNoSuchWallet ()))
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Maybe Wallet
Nothing -> Either ErrNoSuchWallet ()
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrNoSuchWallet ()
 -> ReaderT SqlBackend IO (Either ErrNoSuchWallet ()))
-> Either ErrNoSuchWallet ()
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall a b. (a -> b) -> a -> b
$ ErrNoSuchWallet -> Either ErrNoSuchWallet ()
forall a b. a -> Either a b
Left (ErrNoSuchWallet -> Either ErrNoSuchWallet ())
-> ErrNoSuchWallet -> Either ErrNoSuchWallet ()
forall a b. (a -> b) -> a -> b
$ WalletId -> ErrNoSuchWallet
ErrNoSuchWallet WalletId
wid
                Just Wallet
_ -> DBVar (SqlPersistT IO) DeltaTxWalletsHistory
-> ((TxHistory, Map WalletId TxMetaHistory)
    -> (Maybe DeltaTxWalletsHistory, Either ErrNoSuchWallet ()))
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall da (m :: * -> *) a b.
(Delta da, Monad m, a ~ Base da) =>
DBVar m da -> (a -> (Maybe da, b)) -> m b
modifyDBMaybe DBVar (SqlPersistT IO) DeltaTxWalletsHistory
transactionsDBVar (((TxHistory, Map WalletId TxMetaHistory)
  -> (Maybe DeltaTxWalletsHistory, Either ErrNoSuchWallet ()))
 -> ReaderT SqlBackend IO (Either ErrNoSuchWallet ()))
-> ((TxHistory, Map WalletId TxMetaHistory)
    -> (Maybe DeltaTxWalletsHistory, Either ErrNoSuchWallet ()))
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall a b. (a -> b) -> a -> b
$ \(TxHistory, Map WalletId TxMetaHistory)
_ ->
                    let
                        delta :: Maybe DeltaTxWalletsHistory
delta = DeltaTxWalletsHistory -> Maybe DeltaTxWalletsHistory
forall a. a -> Maybe a
Just
                            (DeltaTxWalletsHistory -> Maybe DeltaTxWalletsHistory)
-> DeltaTxWalletsHistory -> Maybe DeltaTxWalletsHistory
forall a b. (a -> b) -> a -> b
$ WalletId -> ManipulateTxMetaHistory -> DeltaTxWalletsHistory
ChangeTxMetaWalletsHistory WalletId
wid
                            (ManipulateTxMetaHistory -> DeltaTxWalletsHistory)
-> ManipulateTxMetaHistory -> DeltaTxWalletsHistory
forall a b. (a -> b) -> a -> b
$ SlotNo -> ManipulateTxMetaHistory
AgeTxMetaHistory SlotNo
tip
                    in  (Maybe DeltaTxWalletsHistory
delta, () -> Either ErrNoSuchWallet ()
forall a b. b -> Either a b
Right ())

        , removePendingOrExpiredTx :: WalletId -> Hash "Tx" -> ExceptT ErrRemoveTx (SqlPersistT IO) ()
removePendingOrExpiredTx = \WalletId
wid Hash "Tx"
txId ->
            let noTx :: (Maybe a, Either ErrRemoveTx b)
noTx =
                    (   Maybe a
forall a. Maybe a
Nothing
                        , ErrRemoveTx -> Either ErrRemoveTx b
forall a b. a -> Either a b
Left
                            (ErrRemoveTx -> Either ErrRemoveTx b)
-> ErrRemoveTx -> Either ErrRemoveTx b
forall a b. (a -> b) -> a -> b
$ ErrNoSuchTransaction -> ErrRemoveTx
ErrRemoveTxNoSuchTransaction
                            (ErrNoSuchTransaction -> ErrRemoveTx)
-> ErrNoSuchTransaction -> ErrRemoveTx
forall a b. (a -> b) -> a -> b
$ WalletId -> Hash "Tx" -> ErrNoSuchTransaction
ErrNoSuchTransaction WalletId
wid Hash "Tx"
txId
                    )
            in ReaderT SqlBackend IO (Either ErrRemoveTx ())
-> ExceptT ErrRemoveTx (SqlPersistT IO) ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT SqlBackend IO (Either ErrRemoveTx ())
 -> ExceptT ErrRemoveTx (SqlPersistT IO) ())
-> ReaderT SqlBackend IO (Either ErrRemoveTx ())
-> ExceptT ErrRemoveTx (SqlPersistT IO) ()
forall a b. (a -> b) -> a -> b
$ WalletId -> SqlPersistT IO (Maybe Wallet)
forall (m :: * -> *).
MonadIO m =>
WalletId -> SqlPersistT m (Maybe Wallet)
selectWallet WalletId
wid SqlPersistT IO (Maybe Wallet)
-> (Maybe Wallet -> ReaderT SqlBackend IO (Either ErrRemoveTx ()))
-> ReaderT SqlBackend IO (Either ErrRemoveTx ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Maybe Wallet
Nothing -> Either ErrRemoveTx ()
-> ReaderT SqlBackend IO (Either ErrRemoveTx ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrRemoveTx ()
 -> ReaderT SqlBackend IO (Either ErrRemoveTx ()))
-> Either ErrRemoveTx ()
-> ReaderT SqlBackend IO (Either ErrRemoveTx ())
forall a b. (a -> b) -> a -> b
$ ErrRemoveTx -> Either ErrRemoveTx ()
forall a b. a -> Either a b
Left
                    (ErrRemoveTx -> Either ErrRemoveTx ())
-> ErrRemoveTx -> Either ErrRemoveTx ()
forall a b. (a -> b) -> a -> b
$ ErrNoSuchWallet -> ErrRemoveTx
ErrRemoveTxNoSuchWallet
                    (ErrNoSuchWallet -> ErrRemoveTx) -> ErrNoSuchWallet -> ErrRemoveTx
forall a b. (a -> b) -> a -> b
$ WalletId -> ErrNoSuchWallet
ErrNoSuchWallet WalletId
wid
                Just Wallet
_ -> DBVar (SqlPersistT IO) DeltaTxWalletsHistory
-> ((TxHistory, Map WalletId TxMetaHistory)
    -> (Maybe DeltaTxWalletsHistory, Either ErrRemoveTx ()))
-> ReaderT SqlBackend IO (Either ErrRemoveTx ())
forall da (m :: * -> *) a b.
(Delta da, Monad m, a ~ Base da) =>
DBVar m da -> (a -> (Maybe da, b)) -> m b
modifyDBMaybe DBVar (SqlPersistT IO) DeltaTxWalletsHistory
transactionsDBVar
                    (((TxHistory, Map WalletId TxMetaHistory)
  -> (Maybe DeltaTxWalletsHistory, Either ErrRemoveTx ()))
 -> ReaderT SqlBackend IO (Either ErrRemoveTx ()))
-> ((TxHistory, Map WalletId TxMetaHistory)
    -> (Maybe DeltaTxWalletsHistory, Either ErrRemoveTx ()))
-> ReaderT SqlBackend IO (Either ErrRemoveTx ())
forall a b. (a -> b) -> a -> b
$ \(TxHistoryF Map TxId (TxRelationF 'Without)
_txsOld, Map WalletId TxMetaHistory
ws) -> (Maybe DeltaTxWalletsHistory, Either ErrRemoveTx ())
-> Maybe (Maybe DeltaTxWalletsHistory, Either ErrRemoveTx ())
-> (Maybe DeltaTxWalletsHistory, Either ErrRemoveTx ())
forall a. a -> Maybe a -> a
fromMaybe (Maybe DeltaTxWalletsHistory, Either ErrRemoveTx ())
forall a b. (Maybe a, Either ErrRemoveTx b)
noTx (Maybe (Maybe DeltaTxWalletsHistory, Either ErrRemoveTx ())
 -> (Maybe DeltaTxWalletsHistory, Either ErrRemoveTx ()))
-> Maybe (Maybe DeltaTxWalletsHistory, Either ErrRemoveTx ())
-> (Maybe DeltaTxWalletsHistory, Either ErrRemoveTx ())
forall a b. (a -> b) -> a -> b
$ do
                        TxMetaHistory Map TxId TxMeta
metas <- WalletId -> Map WalletId TxMetaHistory -> Maybe TxMetaHistory
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup WalletId
wid Map WalletId TxMetaHistory
ws
                        DB.TxMeta{Maybe Bool
Maybe Word64
Maybe TxMetadata
Maybe SlotNo
Word32
SlotNo
Coin
Direction
TxStatus
WalletId
TxId
txMetaScriptValidity :: Maybe Bool
txMetaFee :: Maybe Word64
txMetaSlotExpires :: Maybe SlotNo
txMetadata :: Maybe TxMetadata
txMetaAmount :: Coin
txMetaBlockHeight :: Word32
txMetaSlot :: SlotNo
txMetaDirection :: Direction
txMetaStatus :: TxStatus
txMetaWalletId :: WalletId
txMetaTxId :: TxId
txMetaScriptValidity :: TxMeta -> Maybe Bool
txMetaFee :: TxMeta -> Maybe Word64
txMetaSlotExpires :: TxMeta -> Maybe SlotNo
txMetadata :: TxMeta -> Maybe TxMetadata
txMetaAmount :: TxMeta -> Coin
txMetaBlockHeight :: TxMeta -> Word32
txMetaSlot :: TxMeta -> SlotNo
txMetaDirection :: TxMeta -> Direction
txMetaStatus :: TxMeta -> TxStatus
txMetaWalletId :: TxMeta -> WalletId
txMetaTxId :: TxMeta -> TxId
..} <- TxId -> Map TxId TxMeta -> Maybe TxMeta
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Hash "Tx" -> TxId
TxId Hash "Tx"
txId) Map TxId TxMeta
metas
                        (Maybe DeltaTxWalletsHistory, Either ErrRemoveTx ())
-> Maybe (Maybe DeltaTxWalletsHistory, Either ErrRemoveTx ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Maybe DeltaTxWalletsHistory, Either ErrRemoveTx ())
 -> Maybe (Maybe DeltaTxWalletsHistory, Either ErrRemoveTx ()))
-> (Maybe DeltaTxWalletsHistory, Either ErrRemoveTx ())
-> Maybe (Maybe DeltaTxWalletsHistory, Either ErrRemoveTx ())
forall a b. (a -> b) -> a -> b
$
                            if TxStatus
txMetaStatus TxStatus -> TxStatus -> Bool
forall a. Eq a => a -> a -> Bool
== TxStatus
W.InLedger
                            then (Maybe DeltaTxWalletsHistory
forall a. Maybe a
Nothing
                                , ErrRemoveTx -> Either ErrRemoveTx ()
forall a b. a -> Either a b
Left (ErrRemoveTx -> Either ErrRemoveTx ())
-> ErrRemoveTx -> Either ErrRemoveTx ()
forall a b. (a -> b) -> a -> b
$ Hash "Tx" -> ErrRemoveTx
ErrRemoveTxAlreadyInLedger Hash "Tx"
txId)
                            else
                                let delta :: Maybe DeltaTxWalletsHistory
delta = DeltaTxWalletsHistory -> Maybe DeltaTxWalletsHistory
forall a. a -> Maybe a
Just
                                        (DeltaTxWalletsHistory -> Maybe DeltaTxWalletsHistory)
-> DeltaTxWalletsHistory -> Maybe DeltaTxWalletsHistory
forall a b. (a -> b) -> a -> b
$ WalletId -> ManipulateTxMetaHistory -> DeltaTxWalletsHistory
ChangeTxMetaWalletsHistory WalletId
wid
                                        (ManipulateTxMetaHistory -> DeltaTxWalletsHistory)
-> ManipulateTxMetaHistory -> DeltaTxWalletsHistory
forall a b. (a -> b) -> a -> b
$ TxId -> ManipulateTxMetaHistory
PruneTxMetaHistory (TxId -> ManipulateTxMetaHistory)
-> TxId -> ManipulateTxMetaHistory
forall a b. (a -> b) -> a -> b
$ Hash "Tx" -> TxId
TxId Hash "Tx"
txId
                                in  (Maybe DeltaTxWalletsHistory
delta, () -> Either ErrRemoveTx ()
forall a b. b -> Either a b
Right ())

        , getTx :: WalletId
-> Hash "Tx"
-> ExceptT ErrNoSuchWallet (SqlPersistT IO) (Maybe TransactionInfo)
getTx = \WalletId
wid Hash "Tx"
tid -> ReaderT
  SqlBackend IO (Either ErrNoSuchWallet (Maybe TransactionInfo))
-> ExceptT ErrNoSuchWallet (SqlPersistT IO) (Maybe TransactionInfo)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT
   SqlBackend IO (Either ErrNoSuchWallet (Maybe TransactionInfo))
 -> ExceptT
      ErrNoSuchWallet (SqlPersistT IO) (Maybe TransactionInfo))
-> ReaderT
     SqlBackend IO (Either ErrNoSuchWallet (Maybe TransactionInfo))
-> ExceptT ErrNoSuchWallet (SqlPersistT IO) (Maybe TransactionInfo)
forall a b. (a -> b) -> a -> b
$ do
            WalletId -> SqlPersistT IO (Maybe (Wallet s))
readCheckpoint_ WalletId
wid SqlPersistT IO (Maybe (Wallet s))
-> (Maybe (Wallet s)
    -> ReaderT
         SqlBackend IO (Either ErrNoSuchWallet (Maybe TransactionInfo)))
-> ReaderT
     SqlBackend IO (Either ErrNoSuchWallet (Maybe TransactionInfo))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Maybe (Wallet s)
Nothing -> Either ErrNoSuchWallet (Maybe TransactionInfo)
-> ReaderT
     SqlBackend IO (Either ErrNoSuchWallet (Maybe TransactionInfo))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrNoSuchWallet (Maybe TransactionInfo)
 -> ReaderT
      SqlBackend IO (Either ErrNoSuchWallet (Maybe TransactionInfo)))
-> Either ErrNoSuchWallet (Maybe TransactionInfo)
-> ReaderT
     SqlBackend IO (Either ErrNoSuchWallet (Maybe TransactionInfo))
forall a b. (a -> b) -> a -> b
$ ErrNoSuchWallet -> Either ErrNoSuchWallet (Maybe TransactionInfo)
forall a b. a -> Either a b
Left (ErrNoSuchWallet -> Either ErrNoSuchWallet (Maybe TransactionInfo))
-> ErrNoSuchWallet
-> Either ErrNoSuchWallet (Maybe TransactionInfo)
forall a b. (a -> b) -> a -> b
$ WalletId -> ErrNoSuchWallet
ErrNoSuchWallet WalletId
wid
                Just Wallet s
cp -> do
                    (TxHistory, Map WalletId TxMetaHistory)
txHistory <- DBVar (SqlPersistT IO) DeltaTxWalletsHistory
-> SqlPersistT IO (TxHistory, Map WalletId TxMetaHistory)
forall da a (m :: * -> *).
(Delta da, a ~ Base da) =>
DBVar m da -> m a
readDBVar DBVar (SqlPersistT IO) DeltaTxWalletsHistory
transactionsDBVar
                    [TransactionInfo]
metas <- IO [TransactionInfo] -> ReaderT SqlBackend IO [TransactionInfo]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO [TransactionInfo] -> ReaderT SqlBackend IO [TransactionInfo])
-> IO [TransactionInfo] -> ReaderT SqlBackend IO [TransactionInfo]
forall a b. (a -> b) -> a -> b
$ Wallet s
-> TimeInterpreter IO
-> WalletId
-> Maybe Coin
-> SortOrder
-> (TxMeta -> Bool)
-> (TxHistory, Map WalletId TxMetaHistory)
-> IO [TransactionInfo]
forall (m :: * -> *) s.
Monad m =>
Wallet s
-> TimeInterpreter m
-> WalletId
-> Maybe Coin
-> SortOrder
-> (TxMeta -> Bool)
-> (TxHistory, Map WalletId TxMetaHistory)
-> m [TransactionInfo]
selectTxHistory Wallet s
cp
                        TimeInterpreter IO
ti WalletId
wid Maybe Coin
forall a. Maybe a
Nothing SortOrder
W.Descending
                            (\TxMeta
meta -> TxMeta -> TxId
txMetaTxId TxMeta
meta TxId -> TxId -> Bool
forall a. Eq a => a -> a -> Bool
== Hash "Tx" -> TxId
TxId Hash "Tx"
tid )
                            (TxHistory, Map WalletId TxMetaHistory)
txHistory
                    Either ErrNoSuchWallet (Maybe TransactionInfo)
-> ReaderT
     SqlBackend IO (Either ErrNoSuchWallet (Maybe TransactionInfo))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrNoSuchWallet (Maybe TransactionInfo)
 -> ReaderT
      SqlBackend IO (Either ErrNoSuchWallet (Maybe TransactionInfo)))
-> Either ErrNoSuchWallet (Maybe TransactionInfo)
-> ReaderT
     SqlBackend IO (Either ErrNoSuchWallet (Maybe TransactionInfo))
forall a b. (a -> b) -> a -> b
$ Maybe TransactionInfo
-> Either ErrNoSuchWallet (Maybe TransactionInfo)
forall a b. b -> Either a b
Right (Maybe TransactionInfo
 -> Either ErrNoSuchWallet (Maybe TransactionInfo))
-> Maybe TransactionInfo
-> Either ErrNoSuchWallet (Maybe TransactionInfo)
forall a b. (a -> b) -> a -> b
$ [TransactionInfo] -> Maybe TransactionInfo
forall a. [a] -> Maybe a
listToMaybe [TransactionInfo]
metas

        {-----------------------------------------------------------------------
                                       Keystore
        -----------------------------------------------------------------------}

        , putPrivateKey :: WalletId
-> (k 'RootK XPrv, PassphraseHash)
-> ExceptT ErrNoSuchWallet (SqlPersistT IO) ()
putPrivateKey = \WalletId
wid (k 'RootK XPrv, PassphraseHash)
key -> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
-> ExceptT ErrNoSuchWallet (SqlPersistT IO) ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
 -> ExceptT ErrNoSuchWallet (SqlPersistT IO) ())
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
-> ExceptT ErrNoSuchWallet (SqlPersistT IO) ()
forall a b. (a -> b) -> a -> b
$ do
            WalletId -> SqlPersistT IO (Maybe Wallet)
forall (m :: * -> *).
MonadIO m =>
WalletId -> SqlPersistT m (Maybe Wallet)
selectWallet WalletId
wid SqlPersistT IO (Maybe Wallet)
-> (Maybe Wallet
    -> ReaderT SqlBackend IO (Either ErrNoSuchWallet ()))
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Maybe Wallet
Nothing -> Either ErrNoSuchWallet ()
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrNoSuchWallet ()
 -> ReaderT SqlBackend IO (Either ErrNoSuchWallet ()))
-> Either ErrNoSuchWallet ()
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall a b. (a -> b) -> a -> b
$ ErrNoSuchWallet -> Either ErrNoSuchWallet ()
forall a b. a -> Either a b
Left (ErrNoSuchWallet -> Either ErrNoSuchWallet ())
-> ErrNoSuchWallet -> Either ErrNoSuchWallet ()
forall a b. (a -> b) -> a -> b
$ WalletId -> ErrNoSuchWallet
ErrNoSuchWallet WalletId
wid
                Just Wallet
_ -> () -> Either ErrNoSuchWallet ()
forall a b. b -> Either a b
Right (() -> Either ErrNoSuchWallet ())
-> SqlPersistT IO ()
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
                    [Filter PrivateKey] -> SqlPersistT IO ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere [EntityField PrivateKey WalletId
forall typ. (typ ~ WalletId) => EntityField PrivateKey typ
PrivateKeyWalletId EntityField PrivateKey WalletId -> WalletId -> Filter PrivateKey
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. WalletId
wid]
                    PrivateKey -> SqlPersistT IO ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
record -> ReaderT backend m ()
insert_ (WalletId -> (k 'RootK XPrv, PassphraseHash) -> PrivateKey
forall (k :: Depth -> * -> *).
PersistPrivateKey (k 'RootK) =>
WalletId -> (k 'RootK XPrv, PassphraseHash) -> PrivateKey
mkPrivateKeyEntity WalletId
wid (k 'RootK XPrv, PassphraseHash)
key)

        , readPrivateKey :: WalletId
-> ReaderT SqlBackend IO (Maybe (k 'RootK XPrv, PassphraseHash))
readPrivateKey = WalletId
-> ReaderT SqlBackend IO (Maybe (k 'RootK XPrv, PassphraseHash))
forall (m :: * -> *) (k :: Depth -> * -> *).
(MonadIO m, PersistPrivateKey (k 'RootK)) =>
WalletId -> SqlPersistT m (Maybe (k 'RootK XPrv, PassphraseHash))
selectPrivateKey

        {-----------------------------------------------------------------------
                                 Blockchain Parameters
        -----------------------------------------------------------------------}

        , readGenesisParameters :: WalletId -> ReaderT SqlBackend IO (Maybe GenesisParameters)
readGenesisParameters = WalletId -> ReaderT SqlBackend IO (Maybe GenesisParameters)
forall (m :: * -> *).
MonadIO m =>
WalletId -> SqlPersistT m (Maybe GenesisParameters)
selectGenesisParameters

        {-----------------------------------------------------------------------
                                 Delegation Rewards
        -----------------------------------------------------------------------}

        , putDelegationRewardBalance :: WalletId -> Coin -> ExceptT ErrNoSuchWallet (SqlPersistT IO) ()
putDelegationRewardBalance =
            \WalletId
wid Coin
amt -> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
-> ExceptT ErrNoSuchWallet (SqlPersistT IO) ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
 -> ExceptT ErrNoSuchWallet (SqlPersistT IO) ())
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
-> ExceptT ErrNoSuchWallet (SqlPersistT IO) ()
forall a b. (a -> b) -> a -> b
$ do
            WalletId -> SqlPersistT IO (Maybe Wallet)
forall (m :: * -> *).
MonadIO m =>
WalletId -> SqlPersistT m (Maybe Wallet)
selectWallet WalletId
wid SqlPersistT IO (Maybe Wallet)
-> (Maybe Wallet
    -> ReaderT SqlBackend IO (Either ErrNoSuchWallet ()))
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Maybe Wallet
Nothing -> Either ErrNoSuchWallet ()
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrNoSuchWallet ()
 -> ReaderT SqlBackend IO (Either ErrNoSuchWallet ()))
-> Either ErrNoSuchWallet ()
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall a b. (a -> b) -> a -> b
$ ErrNoSuchWallet -> Either ErrNoSuchWallet ()
forall a b. a -> Either a b
Left (ErrNoSuchWallet -> Either ErrNoSuchWallet ())
-> ErrNoSuchWallet -> Either ErrNoSuchWallet ()
forall a b. (a -> b) -> a -> b
$ WalletId -> ErrNoSuchWallet
ErrNoSuchWallet WalletId
wid
                Just Wallet
_  -> () -> Either ErrNoSuchWallet ()
forall a b. b -> Either a b
Right (() -> Either ErrNoSuchWallet ())
-> SqlPersistT IO ()
-> ReaderT SqlBackend IO (Either ErrNoSuchWallet ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Key DelegationReward -> DelegationReward -> SqlPersistT IO ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> record -> ReaderT backend m ()
repsert
                    (WalletId -> Key DelegationReward
DelegationRewardKey WalletId
wid)
                    (WalletId -> Word64 -> DelegationReward
DelegationReward WalletId
wid (HasCallStack => Coin -> Word64
Coin -> Word64
Coin.unsafeToWord64 Coin
amt))

        , readDelegationRewardBalance :: WalletId -> ReaderT SqlBackend IO Coin
readDelegationRewardBalance =
            \WalletId
wid ->
                Word64 -> Coin
Coin.fromWord64 (Word64 -> Coin)
-> (Maybe (Entity DelegationReward) -> Word64)
-> Maybe (Entity DelegationReward)
-> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64
-> (Entity DelegationReward -> Word64)
-> Maybe (Entity DelegationReward)
-> Word64
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Word64
0 (DelegationReward -> Word64
rewardAccountBalance (DelegationReward -> Word64)
-> (Entity DelegationReward -> DelegationReward)
-> Entity DelegationReward
-> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity DelegationReward -> DelegationReward
forall record. Entity record -> record
entityVal) (Maybe (Entity DelegationReward) -> Coin)
-> ReaderT SqlBackend IO (Maybe (Entity DelegationReward))
-> ReaderT SqlBackend IO Coin
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                [Filter DelegationReward]
-> [SelectOpt DelegationReward]
-> ReaderT SqlBackend IO (Maybe (Entity DelegationReward))
forall backend (m :: * -> *) record.
(PersistQueryRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m (Maybe (Entity record))
selectFirst [EntityField DelegationReward WalletId
forall typ. (typ ~ WalletId) => EntityField DelegationReward typ
RewardWalletId EntityField DelegationReward WalletId
-> WalletId -> Filter DelegationReward
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. WalletId
wid] []

        {-----------------------------------------------------------------------
                                     ACID Execution
        -----------------------------------------------------------------------}

        , atomically :: forall a. SqlPersistT IO a -> IO a
atomically = MVar () -> (() -> IO a) -> IO a
forall (m :: * -> *) a b.
MonadUnliftIO m =>
MVar a -> (a -> m b) -> m b
withMVar MVar ()
queryLock ((() -> IO a) -> IO a)
-> (SqlPersistT IO a -> () -> IO a) -> SqlPersistT IO a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> () -> IO a
forall a b. a -> b -> a
const (IO a -> () -> IO a)
-> (SqlPersistT IO a -> IO a) -> SqlPersistT IO a -> () -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SqlPersistT IO a -> IO a
forall a. SqlPersistT IO a -> IO a
runQuery
        }

readWalletMetadata
    :: W.WalletId
    -> W.WalletDelegation
    -> SqlPersistT IO (Maybe W.WalletMetadata)
readWalletMetadata :: WalletId
-> WalletDelegation -> ReaderT SqlBackend IO (Maybe WalletMetadata)
readWalletMetadata WalletId
wid WalletDelegation
walDel =
     (Entity Wallet -> WalletMetadata)
-> Maybe (Entity Wallet) -> Maybe WalletMetadata
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (WalletDelegation -> Wallet -> WalletMetadata
metadataFromEntity WalletDelegation
walDel (Wallet -> WalletMetadata)
-> (Entity Wallet -> Wallet) -> Entity Wallet -> WalletMetadata
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity Wallet -> Wallet
forall record. Entity record -> record
entityVal)
        (Maybe (Entity Wallet) -> Maybe WalletMetadata)
-> ReaderT SqlBackend IO (Maybe (Entity Wallet))
-> ReaderT SqlBackend IO (Maybe WalletMetadata)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Filter Wallet]
-> [SelectOpt Wallet]
-> ReaderT SqlBackend IO (Maybe (Entity Wallet))
forall backend (m :: * -> *) record.
(PersistQueryRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m (Maybe (Entity record))
selectFirst [EntityField Wallet WalletId
forall typ. (typ ~ WalletId) => EntityField Wallet typ
WalId EntityField Wallet WalletId -> WalletId -> Filter Wallet
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. WalletId
wid] []

readWalletDelegation
    :: TimeInterpreter IO
    -> W.WalletId
    -> W.EpochNo
    -> SqlPersistT IO W.WalletDelegation
readWalletDelegation :: TimeInterpreter IO
-> WalletId -> EpochNo -> SqlPersistT IO WalletDelegation
readWalletDelegation TimeInterpreter IO
ti WalletId
wid EpochNo
epoch
    | EpochNo
epoch EpochNo -> EpochNo -> Bool
forall a. Eq a => a -> a -> Bool
== EpochNo
0 = WalletDelegation -> SqlPersistT IO WalletDelegation
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WalletDelegation -> SqlPersistT IO WalletDelegation)
-> WalletDelegation -> SqlPersistT IO WalletDelegation
forall a b. (a -> b) -> a -> b
$ WalletDelegationStatus
-> [WalletDelegationNext] -> WalletDelegation
W.WalletDelegation WalletDelegationStatus
W.NotDelegating []
    | Bool
otherwise = do
        (SlotNo
eMinus1, SlotNo
e) <- IO (SlotNo, SlotNo) -> ReaderT SqlBackend IO (SlotNo, SlotNo)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (SlotNo, SlotNo) -> ReaderT SqlBackend IO (SlotNo, SlotNo))
-> IO (SlotNo, SlotNo) -> ReaderT SqlBackend IO (SlotNo, SlotNo)
forall a b. (a -> b) -> a -> b
$ TimeInterpreter IO -> Qry (SlotNo, SlotNo) -> IO (SlotNo, SlotNo)
forall (m :: * -> *) a.
(HasCallStack, Monad m) =>
TimeInterpreter m -> Qry a -> m a
interpretQuery TimeInterpreter IO
ti (Qry (SlotNo, SlotNo) -> IO (SlotNo, SlotNo))
-> Qry (SlotNo, SlotNo) -> IO (SlotNo, SlotNo)
forall a b. (a -> b) -> a -> b
$
            (,) (SlotNo -> SlotNo -> (SlotNo, SlotNo))
-> Qry SlotNo -> Qry (SlotNo -> (SlotNo, SlotNo))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EpochNo -> Qry SlotNo
firstSlotInEpoch (EpochNo
epoch EpochNo -> EpochNo -> EpochNo
forall a. Num a => a -> a -> a
- EpochNo
1) Qry (SlotNo -> (SlotNo, SlotNo))
-> Qry SlotNo -> Qry (SlotNo, SlotNo)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> EpochNo -> Qry SlotNo
firstSlotInEpoch EpochNo
epoch
        WalletDelegationStatus
active <- WalletDelegationStatus
-> (DelegationCertificate -> WalletDelegationStatus)
-> Maybe DelegationCertificate
-> WalletDelegationStatus
forall b a. b -> (a -> b) -> Maybe a -> b
maybe WalletDelegationStatus
W.NotDelegating DelegationCertificate -> WalletDelegationStatus
toWalletDelegationStatus
            (Maybe DelegationCertificate -> WalletDelegationStatus)
-> ReaderT SqlBackend IO (Maybe DelegationCertificate)
-> ReaderT SqlBackend IO WalletDelegationStatus
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WalletId
-> [Filter DelegationCertificate]
-> ReaderT SqlBackend IO (Maybe DelegationCertificate)
readDelegationCertificate WalletId
wid
                [ EntityField DelegationCertificate SlotNo
forall typ. (typ ~ SlotNo) => EntityField DelegationCertificate typ
CertSlot EntityField DelegationCertificate SlotNo
-> SlotNo -> Filter DelegationCertificate
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
<. SlotNo
eMinus1
                ]

        [WalletDelegationNext]
next <- [Maybe WalletDelegationNext] -> [WalletDelegationNext]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe WalletDelegationNext] -> [WalletDelegationNext])
-> ReaderT SqlBackend IO [Maybe WalletDelegationNext]
-> ReaderT SqlBackend IO [WalletDelegationNext]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ReaderT SqlBackend IO (Maybe WalletDelegationNext)]
-> ReaderT SqlBackend IO [Maybe WalletDelegationNext]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
            [ (DelegationCertificate -> WalletDelegationNext)
-> Maybe DelegationCertificate -> Maybe WalletDelegationNext
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (EpochNo -> WalletDelegationStatus -> WalletDelegationNext
W.WalletDelegationNext (EpochNo
epoch EpochNo -> EpochNo -> EpochNo
forall a. Num a => a -> a -> a
+ EpochNo
1) (WalletDelegationStatus -> WalletDelegationNext)
-> (DelegationCertificate -> WalletDelegationStatus)
-> DelegationCertificate
-> WalletDelegationNext
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DelegationCertificate -> WalletDelegationStatus
toWalletDelegationStatus)
                (Maybe DelegationCertificate -> Maybe WalletDelegationNext)
-> ReaderT SqlBackend IO (Maybe DelegationCertificate)
-> ReaderT SqlBackend IO (Maybe WalletDelegationNext)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WalletId
-> [Filter DelegationCertificate]
-> ReaderT SqlBackend IO (Maybe DelegationCertificate)
readDelegationCertificate WalletId
wid
                    [ EntityField DelegationCertificate SlotNo
forall typ. (typ ~ SlotNo) => EntityField DelegationCertificate typ
CertSlot EntityField DelegationCertificate SlotNo
-> SlotNo -> Filter DelegationCertificate
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
>=. SlotNo
eMinus1
                    , EntityField DelegationCertificate SlotNo
forall typ. (typ ~ SlotNo) => EntityField DelegationCertificate typ
CertSlot EntityField DelegationCertificate SlotNo
-> SlotNo -> Filter DelegationCertificate
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
<. SlotNo
e
                    ]
            , (DelegationCertificate -> WalletDelegationNext)
-> Maybe DelegationCertificate -> Maybe WalletDelegationNext
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (EpochNo -> WalletDelegationStatus -> WalletDelegationNext
W.WalletDelegationNext (EpochNo
epoch EpochNo -> EpochNo -> EpochNo
forall a. Num a => a -> a -> a
+ EpochNo
2) (WalletDelegationStatus -> WalletDelegationNext)
-> (DelegationCertificate -> WalletDelegationStatus)
-> DelegationCertificate
-> WalletDelegationNext
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DelegationCertificate -> WalletDelegationStatus
toWalletDelegationStatus)
                (Maybe DelegationCertificate -> Maybe WalletDelegationNext)
-> ReaderT SqlBackend IO (Maybe DelegationCertificate)
-> ReaderT SqlBackend IO (Maybe WalletDelegationNext)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WalletId
-> [Filter DelegationCertificate]
-> ReaderT SqlBackend IO (Maybe DelegationCertificate)
readDelegationCertificate WalletId
wid
                    [ EntityField DelegationCertificate SlotNo
forall typ. (typ ~ SlotNo) => EntityField DelegationCertificate typ
CertSlot EntityField DelegationCertificate SlotNo
-> SlotNo -> Filter DelegationCertificate
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
>=. SlotNo
e
                    ]
            ]

        WalletDelegation -> SqlPersistT IO WalletDelegation
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WalletDelegation -> SqlPersistT IO WalletDelegation)
-> WalletDelegation -> SqlPersistT IO WalletDelegation
forall a b. (a -> b) -> a -> b
$ WalletDelegationStatus
-> [WalletDelegationNext] -> WalletDelegation
W.WalletDelegation WalletDelegationStatus
active [WalletDelegationNext]
next

readDelegationCertificate
    :: W.WalletId
    -> [Filter DelegationCertificate]
    -> SqlPersistT IO (Maybe DelegationCertificate)
readDelegationCertificate :: WalletId
-> [Filter DelegationCertificate]
-> ReaderT SqlBackend IO (Maybe DelegationCertificate)
readDelegationCertificate WalletId
wid [Filter DelegationCertificate]
filters = (Entity DelegationCertificate -> DelegationCertificate)
-> Maybe (Entity DelegationCertificate)
-> Maybe DelegationCertificate
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Entity DelegationCertificate -> DelegationCertificate
forall record. Entity record -> record
entityVal
    (Maybe (Entity DelegationCertificate)
 -> Maybe DelegationCertificate)
-> ReaderT SqlBackend IO (Maybe (Entity DelegationCertificate))
-> ReaderT SqlBackend IO (Maybe DelegationCertificate)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Filter DelegationCertificate]
-> [SelectOpt DelegationCertificate]
-> ReaderT SqlBackend IO (Maybe (Entity DelegationCertificate))
forall backend (m :: * -> *) record.
(PersistQueryRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m (Maybe (Entity record))
selectFirst ((EntityField DelegationCertificate WalletId
forall typ.
(typ ~ WalletId) =>
EntityField DelegationCertificate typ
CertWalletId EntityField DelegationCertificate WalletId
-> WalletId -> Filter DelegationCertificate
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. WalletId
wid) Filter DelegationCertificate
-> [Filter DelegationCertificate] -> [Filter DelegationCertificate]
forall a. a -> [a] -> [a]
: [Filter DelegationCertificate]
filters) [EntityField DelegationCertificate SlotNo
-> SelectOpt DelegationCertificate
forall record typ. EntityField record typ -> SelectOpt record
Desc EntityField DelegationCertificate SlotNo
forall typ. (typ ~ SlotNo) => EntityField DelegationCertificate typ
CertSlot]

{-------------------------------------------------------------------------------
    Conversion between types
        from the `persistent` database (Cardano.Wallet.DB.Sqlite.Schema)
        and from the wallet core ( Cardano.Wallet.Primitive.Types.*)
-------------------------------------------------------------------------------}

toWalletDelegationStatus
    :: DelegationCertificate
    -> W.WalletDelegationStatus
toWalletDelegationStatus :: DelegationCertificate -> WalletDelegationStatus
toWalletDelegationStatus = \case
    DelegationCertificate WalletId
_ SlotNo
_ Maybe PoolId
Nothing ->
        WalletDelegationStatus
W.NotDelegating
    DelegationCertificate WalletId
_ SlotNo
_ (Just PoolId
pool) ->
        PoolId -> WalletDelegationStatus
W.Delegating PoolId
pool

mkWalletEntity :: W.WalletId -> W.WalletMetadata -> W.GenesisParameters -> Wallet
mkWalletEntity :: WalletId -> WalletMetadata -> GenesisParameters -> Wallet
mkWalletEntity WalletId
wid WalletMetadata
meta GenesisParameters
gp = Wallet :: WalletId
-> UTCTime
-> Text
-> Maybe UTCTime
-> Maybe PassphraseScheme
-> BlockId
-> UTCTime
-> Wallet
Wallet
    { walId :: WalletId
walId = WalletId
wid
    , walName :: Text
walName = WalletMetadata
meta WalletMetadata
-> ((Text -> Const Text Text)
    -> WalletMetadata -> Const Text WalletMetadata)
-> Text
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "name"
  ((WalletName -> Const Text WalletName)
   -> WalletMetadata -> Const Text WalletMetadata)
(WalletName -> Const Text WalletName)
-> WalletMetadata -> Const Text WalletMetadata
#name ((WalletName -> Const Text WalletName)
 -> WalletMetadata -> Const Text WalletMetadata)
-> ((Text -> Const Text Text)
    -> WalletName -> Const Text WalletName)
-> (Text -> Const Text Text)
-> WalletMetadata
-> Const Text WalletMetadata
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const Text Text) -> WalletName -> Const Text WalletName
coerce
    , walCreationTime :: UTCTime
walCreationTime = WalletMetadata
meta WalletMetadata
-> ((UTCTime -> Const UTCTime UTCTime)
    -> WalletMetadata -> Const UTCTime WalletMetadata)
-> UTCTime
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "creationTime"
  ((UTCTime -> Const UTCTime UTCTime)
   -> WalletMetadata -> Const UTCTime WalletMetadata)
(UTCTime -> Const UTCTime UTCTime)
-> WalletMetadata -> Const UTCTime WalletMetadata
#creationTime
    , walPassphraseLastUpdatedAt :: Maybe UTCTime
walPassphraseLastUpdatedAt = WalletPassphraseInfo -> UTCTime
W.lastUpdatedAt (WalletPassphraseInfo -> UTCTime)
-> Maybe WalletPassphraseInfo -> Maybe UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WalletMetadata
meta WalletMetadata
-> ((Maybe WalletPassphraseInfo
     -> Const (Maybe WalletPassphraseInfo) (Maybe WalletPassphraseInfo))
    -> WalletMetadata
    -> Const (Maybe WalletPassphraseInfo) WalletMetadata)
-> Maybe WalletPassphraseInfo
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "passphraseInfo"
  ((Maybe WalletPassphraseInfo
    -> Const (Maybe WalletPassphraseInfo) (Maybe WalletPassphraseInfo))
   -> WalletMetadata
   -> Const (Maybe WalletPassphraseInfo) WalletMetadata)
(Maybe WalletPassphraseInfo
 -> Const (Maybe WalletPassphraseInfo) (Maybe WalletPassphraseInfo))
-> WalletMetadata
-> Const (Maybe WalletPassphraseInfo) WalletMetadata
#passphraseInfo
    , walPassphraseScheme :: Maybe PassphraseScheme
walPassphraseScheme = WalletPassphraseInfo -> PassphraseScheme
W.passphraseScheme (WalletPassphraseInfo -> PassphraseScheme)
-> Maybe WalletPassphraseInfo -> Maybe PassphraseScheme
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WalletMetadata
meta WalletMetadata
-> ((Maybe WalletPassphraseInfo
     -> Const (Maybe WalletPassphraseInfo) (Maybe WalletPassphraseInfo))
    -> WalletMetadata
    -> Const (Maybe WalletPassphraseInfo) WalletMetadata)
-> Maybe WalletPassphraseInfo
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "passphraseInfo"
  ((Maybe WalletPassphraseInfo
    -> Const (Maybe WalletPassphraseInfo) (Maybe WalletPassphraseInfo))
   -> WalletMetadata
   -> Const (Maybe WalletPassphraseInfo) WalletMetadata)
(Maybe WalletPassphraseInfo
 -> Const (Maybe WalletPassphraseInfo) (Maybe WalletPassphraseInfo))
-> WalletMetadata
-> Const (Maybe WalletPassphraseInfo) WalletMetadata
#passphraseInfo
    , walGenesisHash :: BlockId
walGenesisHash = Hash "BlockHeader" -> BlockId
BlockId (Hash "Genesis" -> Hash "BlockHeader"
coerce (GenesisParameters
gp GenesisParameters
-> ((Hash "Genesis" -> Const (Hash "Genesis") (Hash "Genesis"))
    -> GenesisParameters -> Const (Hash "Genesis") GenesisParameters)
-> Hash "Genesis"
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "getGenesisBlockHash"
  ((Hash "Genesis" -> Const (Hash "Genesis") (Hash "Genesis"))
   -> GenesisParameters -> Const (Hash "Genesis") GenesisParameters)
(Hash "Genesis" -> Const (Hash "Genesis") (Hash "Genesis"))
-> GenesisParameters -> Const (Hash "Genesis") GenesisParameters
#getGenesisBlockHash))
    , walGenesisStart :: UTCTime
walGenesisStart = StartTime -> UTCTime
coerce (GenesisParameters
gp GenesisParameters
-> ((StartTime -> Const StartTime StartTime)
    -> GenesisParameters -> Const StartTime GenesisParameters)
-> StartTime
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "getGenesisBlockDate"
  ((StartTime -> Const StartTime StartTime)
   -> GenesisParameters -> Const StartTime GenesisParameters)
(StartTime -> Const StartTime StartTime)
-> GenesisParameters -> Const StartTime GenesisParameters
#getGenesisBlockDate)
    }

mkWalletMetadataUpdate :: W.WalletMetadata -> [Update Wallet]
mkWalletMetadataUpdate :: WalletMetadata -> [Update Wallet]
mkWalletMetadataUpdate WalletMetadata
meta =
    [ EntityField Wallet Text
forall typ. (typ ~ Text) => EntityField Wallet typ
WalName EntityField Wallet Text -> Text -> Update Wallet
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. WalletMetadata
meta WalletMetadata
-> ((Text -> Const Text Text)
    -> WalletMetadata -> Const Text WalletMetadata)
-> Text
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "name"
  ((WalletName -> Const Text WalletName)
   -> WalletMetadata -> Const Text WalletMetadata)
(WalletName -> Const Text WalletName)
-> WalletMetadata -> Const Text WalletMetadata
#name ((WalletName -> Const Text WalletName)
 -> WalletMetadata -> Const Text WalletMetadata)
-> ((Text -> Const Text Text)
    -> WalletName -> Const Text WalletName)
-> (Text -> Const Text Text)
-> WalletMetadata
-> Const Text WalletMetadata
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const Text Text) -> WalletName -> Const Text WalletName
coerce
    , EntityField Wallet UTCTime
forall typ. (typ ~ UTCTime) => EntityField Wallet typ
WalCreationTime EntityField Wallet UTCTime -> UTCTime -> Update Wallet
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. WalletMetadata
meta WalletMetadata
-> ((UTCTime -> Const UTCTime UTCTime)
    -> WalletMetadata -> Const UTCTime WalletMetadata)
-> UTCTime
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "creationTime"
  ((UTCTime -> Const UTCTime UTCTime)
   -> WalletMetadata -> Const UTCTime WalletMetadata)
(UTCTime -> Const UTCTime UTCTime)
-> WalletMetadata -> Const UTCTime WalletMetadata
#creationTime
    , EntityField Wallet (Maybe UTCTime)
forall typ. (typ ~ Maybe UTCTime) => EntityField Wallet typ
WalPassphraseLastUpdatedAt EntityField Wallet (Maybe UTCTime)
-> Maybe UTCTime -> Update Wallet
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=.
        WalletPassphraseInfo -> UTCTime
W.lastUpdatedAt (WalletPassphraseInfo -> UTCTime)
-> Maybe WalletPassphraseInfo -> Maybe UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WalletMetadata
meta WalletMetadata
-> ((Maybe WalletPassphraseInfo
     -> Const (Maybe WalletPassphraseInfo) (Maybe WalletPassphraseInfo))
    -> WalletMetadata
    -> Const (Maybe WalletPassphraseInfo) WalletMetadata)
-> Maybe WalletPassphraseInfo
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "passphraseInfo"
  ((Maybe WalletPassphraseInfo
    -> Const (Maybe WalletPassphraseInfo) (Maybe WalletPassphraseInfo))
   -> WalletMetadata
   -> Const (Maybe WalletPassphraseInfo) WalletMetadata)
(Maybe WalletPassphraseInfo
 -> Const (Maybe WalletPassphraseInfo) (Maybe WalletPassphraseInfo))
-> WalletMetadata
-> Const (Maybe WalletPassphraseInfo) WalletMetadata
#passphraseInfo
    , EntityField Wallet (Maybe PassphraseScheme)
forall typ.
(typ ~ Maybe PassphraseScheme) =>
EntityField Wallet typ
WalPassphraseScheme EntityField Wallet (Maybe PassphraseScheme)
-> Maybe PassphraseScheme -> Update Wallet
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=.
        WalletPassphraseInfo -> PassphraseScheme
W.passphraseScheme (WalletPassphraseInfo -> PassphraseScheme)
-> Maybe WalletPassphraseInfo -> Maybe PassphraseScheme
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WalletMetadata
meta WalletMetadata
-> ((Maybe WalletPassphraseInfo
     -> Const (Maybe WalletPassphraseInfo) (Maybe WalletPassphraseInfo))
    -> WalletMetadata
    -> Const (Maybe WalletPassphraseInfo) WalletMetadata)
-> Maybe WalletPassphraseInfo
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "passphraseInfo"
  ((Maybe WalletPassphraseInfo
    -> Const (Maybe WalletPassphraseInfo) (Maybe WalletPassphraseInfo))
   -> WalletMetadata
   -> Const (Maybe WalletPassphraseInfo) WalletMetadata)
(Maybe WalletPassphraseInfo
 -> Const (Maybe WalletPassphraseInfo) (Maybe WalletPassphraseInfo))
-> WalletMetadata
-> Const (Maybe WalletPassphraseInfo) WalletMetadata
#passphraseInfo
    ]

metadataFromEntity :: W.WalletDelegation -> Wallet -> W.WalletMetadata
metadataFromEntity :: WalletDelegation -> Wallet -> WalletMetadata
metadataFromEntity WalletDelegation
walDelegation Wallet
wal = WalletMetadata :: WalletName
-> UTCTime
-> Maybe WalletPassphraseInfo
-> WalletDelegation
-> WalletMetadata
W.WalletMetadata
    { $sel:name:WalletMetadata :: WalletName
name = Text -> WalletName
W.WalletName (Wallet -> Text
walName Wallet
wal)
    , $sel:creationTime:WalletMetadata :: UTCTime
creationTime = Wallet -> UTCTime
walCreationTime Wallet
wal
    , $sel:passphraseInfo:WalletMetadata :: Maybe WalletPassphraseInfo
passphraseInfo = UTCTime -> PassphraseScheme -> WalletPassphraseInfo
W.WalletPassphraseInfo
        (UTCTime -> PassphraseScheme -> WalletPassphraseInfo)
-> Maybe UTCTime
-> Maybe (PassphraseScheme -> WalletPassphraseInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Wallet -> Maybe UTCTime
walPassphraseLastUpdatedAt Wallet
wal
        Maybe (PassphraseScheme -> WalletPassphraseInfo)
-> Maybe PassphraseScheme -> Maybe WalletPassphraseInfo
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Wallet -> Maybe PassphraseScheme
walPassphraseScheme Wallet
wal
    , $sel:delegation:WalletMetadata :: WalletDelegation
delegation = WalletDelegation
walDelegation
    }

mkPrivateKeyEntity
    :: PersistPrivateKey (k 'RootK)
    => W.WalletId
    -> (k 'RootK XPrv, W.PassphraseHash)
    -> PrivateKey
mkPrivateKeyEntity :: WalletId -> (k 'RootK XPrv, PassphraseHash) -> PrivateKey
mkPrivateKeyEntity WalletId
wid (k 'RootK XPrv, PassphraseHash)
kh = PrivateKey :: WalletId -> ByteString -> ByteString -> PrivateKey
PrivateKey
    { privateKeyWalletId :: WalletId
privateKeyWalletId = WalletId
wid
    , privateKeyRootKey :: ByteString
privateKeyRootKey = ByteString
root
    , privateKeyHash :: ByteString
privateKeyHash = ByteString
hash
    }
  where
    (ByteString
root, ByteString
hash) = (k 'RootK XPrv, PassphraseHash) -> (ByteString, ByteString)
forall (key :: * -> *).
PersistPrivateKey key =>
(key XPrv, PassphraseHash) -> (ByteString, ByteString)
serializeXPrv (k 'RootK XPrv, PassphraseHash)
kh

privateKeyFromEntity
    :: PersistPrivateKey (k 'RootK)
    => PrivateKey
    -> (k 'RootK XPrv, PassphraseHash)
privateKeyFromEntity :: PrivateKey -> (k 'RootK XPrv, PassphraseHash)
privateKeyFromEntity (PrivateKey WalletId
_ ByteString
k ByteString
h) =
    (ByteString, ByteString) -> (k 'RootK XPrv, PassphraseHash)
forall (key :: * -> *).
PersistPrivateKey key =>
(ByteString, ByteString) -> (key XPrv, PassphraseHash)
unsafeDeserializeXPrv (ByteString
k, ByteString
h)


genesisParametersFromEntity
    :: Wallet
    -> W.GenesisParameters
genesisParametersFromEntity :: Wallet -> GenesisParameters
genesisParametersFromEntity (Wallet WalletId
_ UTCTime
_ Text
_ Maybe UTCTime
_ Maybe PassphraseScheme
_ BlockId
hash UTCTime
startTime) =
    GenesisParameters :: Hash "Genesis" -> StartTime -> GenesisParameters
W.GenesisParameters
        { $sel:getGenesisBlockHash:GenesisParameters :: Hash "Genesis"
W.getGenesisBlockHash = Hash "BlockHeader" -> Hash "Genesis"
coerce (BlockId -> Hash "BlockHeader"
getBlockId BlockId
hash)
        , $sel:getGenesisBlockDate:GenesisParameters :: StartTime
W.getGenesisBlockDate = UTCTime -> StartTime
W.StartTime UTCTime
startTime
        }

{-------------------------------------------------------------------------------
    SQLite database operations
-------------------------------------------------------------------------------}

selectWallet :: MonadIO m => W.WalletId -> SqlPersistT m (Maybe Wallet)
selectWallet :: WalletId -> SqlPersistT m (Maybe Wallet)
selectWallet WalletId
wid =
    (Entity Wallet -> Wallet) -> Maybe (Entity Wallet) -> Maybe Wallet
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Entity Wallet -> Wallet
forall record. Entity record -> record
entityVal (Maybe (Entity Wallet) -> Maybe Wallet)
-> ReaderT SqlBackend m (Maybe (Entity Wallet))
-> SqlPersistT m (Maybe Wallet)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Filter Wallet]
-> [SelectOpt Wallet]
-> ReaderT SqlBackend m (Maybe (Entity Wallet))
forall backend (m :: * -> *) record.
(PersistQueryRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m (Maybe (Entity record))
selectFirst [EntityField Wallet WalletId
forall typ. (typ ~ WalletId) => EntityField Wallet typ
WalId EntityField Wallet WalletId -> WalletId -> Filter Wallet
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. WalletId
wid] []

-- | Delete stake key certificates for a wallet.
deleteStakeKeyCerts
    :: W.WalletId
    -> [Filter StakeKeyCertificate]
    -> SqlPersistT IO ()
deleteStakeKeyCerts :: WalletId -> [Filter StakeKeyCertificate] -> SqlPersistT IO ()
deleteStakeKeyCerts WalletId
wid [Filter StakeKeyCertificate]
filters =
    [Filter StakeKeyCertificate] -> SqlPersistT IO ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere ((EntityField StakeKeyCertificate WalletId
forall typ. (typ ~ WalletId) => EntityField StakeKeyCertificate typ
StakeKeyCertWalletId EntityField StakeKeyCertificate WalletId
-> WalletId -> Filter StakeKeyCertificate
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. WalletId
wid) Filter StakeKeyCertificate
-> [Filter StakeKeyCertificate] -> [Filter StakeKeyCertificate]
forall a. a -> [a] -> [a]
: [Filter StakeKeyCertificate]
filters)

-- | Delete all delegation certificates matching the given filter
deleteDelegationCertificates
    :: W.WalletId
    -> [Filter DelegationCertificate]
    -> SqlPersistT IO ()
deleteDelegationCertificates :: WalletId -> [Filter DelegationCertificate] -> SqlPersistT IO ()
deleteDelegationCertificates WalletId
wid [Filter DelegationCertificate]
filters = do
    [Filter DelegationCertificate] -> SqlPersistT IO ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere ((EntityField DelegationCertificate WalletId
forall typ.
(typ ~ WalletId) =>
EntityField DelegationCertificate typ
CertWalletId EntityField DelegationCertificate WalletId
-> WalletId -> Filter DelegationCertificate
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. WalletId
wid) Filter DelegationCertificate
-> [Filter DelegationCertificate] -> [Filter DelegationCertificate]
forall a. a -> [a] -> [a]
: [Filter DelegationCertificate]
filters)

-- This relies on available information from the database to reconstruct coin
-- selection information for __outgoing__ payments. We can't however guarantee
-- that we have such information for __incoming__ payments (we usually don't
-- have it).
--
-- To reliably provide this information for incoming payments, it should be
-- looked up when applying blocks from the global ledger, but that is future
-- work.
--

-- See also: issue #573.
selectTxHistory
    :: Monad m
    => W.Wallet s
    -> TimeInterpreter m
    -> W.WalletId
    -> Maybe W.Coin
    -> W.SortOrder
    -> (DB.TxMeta -> Bool)
    -> TxWalletsHistory
    -> m [W.TransactionInfo]
selectTxHistory :: Wallet s
-> TimeInterpreter m
-> WalletId
-> Maybe Coin
-> SortOrder
-> (TxMeta -> Bool)
-> (TxHistory, Map WalletId TxMetaHistory)
-> m [TransactionInfo]
selectTxHistory Wallet s
cp TimeInterpreter m
ti WalletId
wid Maybe Coin
minWithdrawal SortOrder
order TxMeta -> Bool
whichMeta
    (TxHistory
txHistory, Map WalletId TxMetaHistory
wmetas) = do
    [TransactionInfo]
tinfos <- ((TxRelationF 'With, TxMeta) -> m TransactionInfo)
-> [(TxRelationF 'With, TxMeta)] -> m [TransactionInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((TxRelationF 'With -> TxMeta -> m TransactionInfo)
-> (TxRelationF 'With, TxMeta) -> m TransactionInfo
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((TxRelationF 'With -> TxMeta -> m TransactionInfo)
 -> (TxRelationF 'With, TxMeta) -> m TransactionInfo)
-> (TxRelationF 'With -> TxMeta -> m TransactionInfo)
-> (TxRelationF 'With, TxMeta)
-> m TransactionInfo
forall a b. (a -> b) -> a -> b
$ TimeInterpreter m
-> BlockHeader -> TxRelationF 'With -> TxMeta -> m TransactionInfo
forall (m :: * -> *).
Monad m =>
TimeInterpreter m
-> BlockHeader -> TxRelationF 'With -> TxMeta -> m TransactionInfo
mkTransactionInfo TimeInterpreter m
ti (Wallet s -> BlockHeader
forall s. Wallet s -> BlockHeader
W.currentTip Wallet s
cp)) ([(TxRelationF 'With, TxMeta)] -> m [TransactionInfo])
-> [(TxRelationF 'With, TxMeta)] -> m [TransactionInfo]
forall a b. (a -> b) -> a -> b
$ do
        TxMetaHistory Map TxId TxMeta
metas <- Maybe TxMetaHistory -> [TxMetaHistory]
forall a. Maybe a -> [a]
maybeToList (Maybe TxMetaHistory -> [TxMetaHistory])
-> Maybe TxMetaHistory -> [TxMetaHistory]
forall a b. (a -> b) -> a -> b
$ WalletId -> Map WalletId TxMetaHistory -> Maybe TxMetaHistory
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup WalletId
wid Map WalletId TxMetaHistory
wmetas
        TxMeta
meta <- Map TxId TxMeta -> [TxMeta]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Map TxId TxMeta
metas
        Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$  TxMeta -> Bool
whichMeta TxMeta
meta
        TxRelationF 'With
transaction <- Maybe (TxRelationF 'With) -> [TxRelationF 'With]
forall a. Maybe a -> [a]
maybeToList (Maybe (TxRelationF 'With) -> [TxRelationF 'With])
-> Maybe (TxRelationF 'With) -> [TxRelationF 'With]
forall a b. (a -> b) -> a -> b
$ TxId -> Map TxId (TxRelationF 'With) -> Maybe (TxRelationF 'With)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (TxMeta -> TxId
txMetaTxId TxMeta
meta) Map TxId (TxRelationF 'With)
txs
        Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ Bool -> (Coin -> Bool) -> Maybe Coin -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
            Bool
True
            (\Coin
coin -> (Coin -> Bool) -> [Coin] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
>= Coin
coin)
                ([Coin] -> Bool) -> [Coin] -> Bool
forall a b. (a -> b) -> a -> b
$ TxWithdrawal -> Coin
txWithdrawalAmount (TxWithdrawal -> Coin) -> [TxWithdrawal] -> [Coin]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>  TxRelationF 'With -> [TxWithdrawal]
forall (f :: Decoration). TxRelationF f -> [TxWithdrawal]
withdrawals TxRelationF 'With
transaction)
            Maybe Coin
minWithdrawal
        (TxRelationF 'With, TxMeta) -> [(TxRelationF 'With, TxMeta)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxRelationF 'With
transaction, TxMeta
meta)
    [TransactionInfo] -> m [TransactionInfo]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TransactionInfo] -> m [TransactionInfo])
-> [TransactionInfo] -> m [TransactionInfo]
forall a b. (a -> b) -> a -> b
$ [TransactionInfo] -> [TransactionInfo]
sortTx [TransactionInfo]
tinfos
    where
        sortTx :: [TransactionInfo] -> [TransactionInfo]
sortTx = case SortOrder
order of
            SortOrder
W.Ascending -> (TransactionInfo -> (SlotNo, Down (Hash "Tx")))
-> [TransactionInfo] -> [TransactionInfo]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn
                ((TransactionInfo -> (SlotNo, Down (Hash "Tx")))
 -> [TransactionInfo] -> [TransactionInfo])
-> (TransactionInfo -> (SlotNo, Down (Hash "Tx")))
-> [TransactionInfo]
-> [TransactionInfo]
forall a b. (a -> b) -> a -> b
$ (,) (SlotNo -> Down (Hash "Tx") -> (SlotNo, Down (Hash "Tx")))
-> (TransactionInfo -> SlotNo)
-> TransactionInfo
-> Down (Hash "Tx")
-> (SlotNo, Down (Hash "Tx"))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TxMeta -> SlotNo
slotNo (TxMeta -> SlotNo)
-> (TransactionInfo -> TxMeta) -> TransactionInfo -> SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransactionInfo -> TxMeta
txInfoMeta (TransactionInfo -> Down (Hash "Tx") -> (SlotNo, Down (Hash "Tx")))
-> (TransactionInfo -> Down (Hash "Tx"))
-> TransactionInfo
-> (SlotNo, Down (Hash "Tx"))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Hash "Tx" -> Down (Hash "Tx")
forall a. a -> Down a
Down (Hash "Tx" -> Down (Hash "Tx"))
-> (TransactionInfo -> Hash "Tx")
-> TransactionInfo
-> Down (Hash "Tx")
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransactionInfo -> Hash "Tx"
txInfoId
            SortOrder
W.Descending -> (TransactionInfo -> (Down SlotNo, Hash "Tx"))
-> [TransactionInfo] -> [TransactionInfo]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn
                ((TransactionInfo -> (Down SlotNo, Hash "Tx"))
 -> [TransactionInfo] -> [TransactionInfo])
-> (TransactionInfo -> (Down SlotNo, Hash "Tx"))
-> [TransactionInfo]
-> [TransactionInfo]
forall a b. (a -> b) -> a -> b
$ (,) (Down SlotNo -> Hash "Tx" -> (Down SlotNo, Hash "Tx"))
-> (TransactionInfo -> Down SlotNo)
-> TransactionInfo
-> Hash "Tx"
-> (Down SlotNo, Hash "Tx")
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SlotNo -> Down SlotNo
forall a. a -> Down a
Down (SlotNo -> Down SlotNo)
-> (TransactionInfo -> SlotNo) -> TransactionInfo -> Down SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxMeta -> SlotNo
slotNo (TxMeta -> SlotNo)
-> (TransactionInfo -> TxMeta) -> TransactionInfo -> SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransactionInfo -> TxMeta
txInfoMeta) (TransactionInfo -> Hash "Tx" -> (Down SlotNo, Hash "Tx"))
-> (TransactionInfo -> Hash "Tx")
-> TransactionInfo
-> (Down SlotNo, Hash "Tx")
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TransactionInfo -> Hash "Tx"
txInfoId
        TxHistoryF Map TxId (TxRelationF 'With)
txs = TxHistory -> TxHistoryF 'With
decorateWithTxOuts TxHistory
txHistory


-- | Returns the initial submission slot and submission record for all pending
-- transactions in the wallet.
listPendingLocalTxSubmissionQuery
    :: W.WalletId
    -> SqlPersistT IO [(W.SlotNo, LocalTxSubmission)]
listPendingLocalTxSubmissionQuery :: WalletId -> ReaderT SqlBackend IO [(SlotNo, LocalTxSubmission)]
listPendingLocalTxSubmissionQuery WalletId
wid = ((Single SlotNo, Entity LocalTxSubmission)
 -> (SlotNo, LocalTxSubmission))
-> [(Single SlotNo, Entity LocalTxSubmission)]
-> [(SlotNo, LocalTxSubmission)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Single SlotNo, Entity LocalTxSubmission)
-> (SlotNo, LocalTxSubmission)
forall a b. (Single a, Entity b) -> (a, b)
unRaw ([(Single SlotNo, Entity LocalTxSubmission)]
 -> [(SlotNo, LocalTxSubmission)])
-> ReaderT
     SqlBackend IO [(Single SlotNo, Entity LocalTxSubmission)]
-> ReaderT SqlBackend IO [(SlotNo, LocalTxSubmission)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> [PersistValue]
-> ReaderT
     SqlBackend IO [(Single SlotNo, Entity LocalTxSubmission)]
forall a (m :: * -> *) backend.
(RawSql a, MonadIO m, BackendCompatible SqlBackend backend) =>
Text -> [PersistValue] -> ReaderT backend m [a]
rawSql Text
query [PersistValue]
params
  where
    -- fixme: sort results
    query :: Text
query =
        Text
"SELECT tx_meta.slot,?? " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
        Text
"FROM tx_meta INNER JOIN local_tx_submission " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
        Text
"ON tx_meta.wallet_id=local_tx_submission.wallet_id " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
        Text
"    AND tx_meta.tx_id=local_tx_submission.tx_id " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
        Text
"WHERE tx_meta.wallet_id=? AND tx_meta.status=? " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
        Text
"ORDER BY local_tx_submission.wallet_id, local_tx_submission.tx_id"
    params :: [PersistValue]
params = [WalletId -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue WalletId
wid, TxStatus -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue TxStatus
W.Pending]
    unRaw :: (Single a, Entity b) -> (a, b)
unRaw (Single a
sl, Entity Key b
_ b
tx) = (a
sl, b
tx)

localTxSubmissionFromEntity
    :: (W.SlotNo, LocalTxSubmission)
    -> W.LocalTxSubmissionStatus W.SealedTx
localTxSubmissionFromEntity :: (SlotNo, LocalTxSubmission) -> LocalTxSubmissionStatus SealedTx
localTxSubmissionFromEntity (SlotNo
sl0, LocalTxSubmission (TxId Hash "Tx"
txid) WalletId
_ SlotNo
sl SealedTx
tx) =
    Hash "Tx"
-> SealedTx -> SlotNo -> SlotNo -> LocalTxSubmissionStatus SealedTx
forall tx.
Hash "Tx" -> tx -> SlotNo -> SlotNo -> LocalTxSubmissionStatus tx
W.LocalTxSubmissionStatus Hash "Tx"
txid SealedTx
tx SlotNo
sl0 SlotNo
sl

-- | Remove transactions from the local submission pool once they can no longer
-- be rolled back.
pruneLocalTxSubmission
    :: W.WalletId
    -> Quantity "block" Word32
    -> W.BlockHeader
    -> SqlPersistT IO ()
pruneLocalTxSubmission :: WalletId
-> Quantity "block" Word32 -> BlockHeader -> SqlPersistT IO ()
pruneLocalTxSubmission WalletId
wid (Quantity Word32
epochStability) BlockHeader
tip =
    Text -> [PersistValue] -> SqlPersistT IO ()
forall (m :: * -> *) backend.
(MonadIO m, BackendCompatible SqlBackend backend) =>
Text -> [PersistValue] -> ReaderT backend m ()
rawExecute Text
query [PersistValue]
params
  where
    query :: Text
query =
        Text
"DELETE FROM local_tx_submission " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
        Text
"WHERE wallet_id=? AND tx_id IN " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
        Text
"( SELECT tx_id FROM tx_meta WHERE tx_meta.block_height < ? )"
    params :: [PersistValue]
params = [WalletId -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue WalletId
wid, Word32 -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue Word32
stableHeight]
    stableHeight :: Word32
stableHeight = Quantity "block" Word32 -> Word32
forall (unit :: Symbol) a. Quantity unit a -> a
getQuantity (BlockHeader
tip BlockHeader
-> ((Quantity "block" Word32
     -> Const (Quantity "block" Word32) (Quantity "block" Word32))
    -> BlockHeader -> Const (Quantity "block" Word32) BlockHeader)
-> Quantity "block" Word32
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. IsLabel
  "blockHeight"
  ((Quantity "block" Word32
    -> Const (Quantity "block" Word32) (Quantity "block" Word32))
   -> BlockHeader -> Const (Quantity "block" Word32) BlockHeader)
(Quantity "block" Word32
 -> Const (Quantity "block" Word32) (Quantity "block" Word32))
-> BlockHeader -> Const (Quantity "block" Word32) BlockHeader
#blockHeight) Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
epochStability

selectPrivateKey
    :: (MonadIO m, PersistPrivateKey (k 'RootK))
    => W.WalletId
    -> SqlPersistT m (Maybe (k 'RootK XPrv, PassphraseHash))
selectPrivateKey :: WalletId -> SqlPersistT m (Maybe (k 'RootK XPrv, PassphraseHash))
selectPrivateKey WalletId
wid = do
    Maybe (Entity PrivateKey)
keys <- [Filter PrivateKey]
-> [SelectOpt PrivateKey]
-> ReaderT SqlBackend m (Maybe (Entity PrivateKey))
forall backend (m :: * -> *) record.
(PersistQueryRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m (Maybe (Entity record))
selectFirst [EntityField PrivateKey WalletId
forall typ. (typ ~ WalletId) => EntityField PrivateKey typ
PrivateKeyWalletId EntityField PrivateKey WalletId -> WalletId -> Filter PrivateKey
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. WalletId
wid] []
    Maybe (k 'RootK XPrv, PassphraseHash)
-> SqlPersistT m (Maybe (k 'RootK XPrv, PassphraseHash))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (k 'RootK XPrv, PassphraseHash)
 -> SqlPersistT m (Maybe (k 'RootK XPrv, PassphraseHash)))
-> Maybe (k 'RootK XPrv, PassphraseHash)
-> SqlPersistT m (Maybe (k 'RootK XPrv, PassphraseHash))
forall a b. (a -> b) -> a -> b
$ (PrivateKey -> (k 'RootK XPrv, PassphraseHash)
forall (k :: Depth -> * -> *).
PersistPrivateKey (k 'RootK) =>
PrivateKey -> (k 'RootK XPrv, PassphraseHash)
privateKeyFromEntity (PrivateKey -> (k 'RootK XPrv, PassphraseHash))
-> (Entity PrivateKey -> PrivateKey)
-> Entity PrivateKey
-> (k 'RootK XPrv, PassphraseHash)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity PrivateKey -> PrivateKey
forall record. Entity record -> record
entityVal) (Entity PrivateKey -> (k 'RootK XPrv, PassphraseHash))
-> Maybe (Entity PrivateKey)
-> Maybe (k 'RootK XPrv, PassphraseHash)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Entity PrivateKey)
keys

selectGenesisParameters
    :: MonadIO m
    => W.WalletId
    -> SqlPersistT m (Maybe W.GenesisParameters)
selectGenesisParameters :: WalletId -> SqlPersistT m (Maybe GenesisParameters)
selectGenesisParameters WalletId
wid = do
    Maybe (Entity Wallet)
gp <- [Filter Wallet]
-> [SelectOpt Wallet]
-> ReaderT SqlBackend m (Maybe (Entity Wallet))
forall backend (m :: * -> *) record.
(PersistQueryRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m (Maybe (Entity record))
selectFirst [EntityField Wallet WalletId
forall typ. (typ ~ WalletId) => EntityField Wallet typ
WalId EntityField Wallet WalletId -> WalletId -> Filter Wallet
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. WalletId
wid] []
    Maybe GenesisParameters -> SqlPersistT m (Maybe GenesisParameters)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe GenesisParameters
 -> SqlPersistT m (Maybe GenesisParameters))
-> Maybe GenesisParameters
-> SqlPersistT m (Maybe GenesisParameters)
forall a b. (a -> b) -> a -> b
$ (Wallet -> GenesisParameters
genesisParametersFromEntity (Wallet -> GenesisParameters)
-> (Entity Wallet -> Wallet) -> Entity Wallet -> GenesisParameters
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity Wallet -> Wallet
forall record. Entity record -> record
entityVal) (Entity Wallet -> GenesisParameters)
-> Maybe (Entity Wallet) -> Maybe GenesisParameters
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Entity Wallet)
gp

{-------------------------------------------------------------------------------
    Internal errors
-------------------------------------------------------------------------------}
-- | A fatal exception thrown when trying to rollback but, there's no checkpoint
-- to rollback to. The database maintain the invariant that there's always at
-- least one checkpoint (the first one made for genesis) present in the
-- database.
--
-- If we don't find any checkpoint, it means that this invariant has been
-- violated.
data ErrRollbackTo = ErrNoOlderCheckpoint W.WalletId W.Slot deriving (Int -> ErrRollbackTo -> FilePath -> FilePath
[ErrRollbackTo] -> FilePath -> FilePath
ErrRollbackTo -> FilePath
(Int -> ErrRollbackTo -> FilePath -> FilePath)
-> (ErrRollbackTo -> FilePath)
-> ([ErrRollbackTo] -> FilePath -> FilePath)
-> Show ErrRollbackTo
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [ErrRollbackTo] -> FilePath -> FilePath
$cshowList :: [ErrRollbackTo] -> FilePath -> FilePath
show :: ErrRollbackTo -> FilePath
$cshow :: ErrRollbackTo -> FilePath
showsPrec :: Int -> ErrRollbackTo -> FilePath -> FilePath
$cshowsPrec :: Int -> ErrRollbackTo -> FilePath -> FilePath
Show)
instance Exception ErrRollbackTo

-- | Can't initialize a wallet because the given 'BlockHeader' is not genesis.
data ErrInitializeGenesisAbsent
    = ErrInitializeGenesisAbsent W.WalletId W.BlockHeader deriving (ErrInitializeGenesisAbsent -> ErrInitializeGenesisAbsent -> Bool
(ErrInitializeGenesisAbsent -> ErrInitializeGenesisAbsent -> Bool)
-> (ErrInitializeGenesisAbsent
    -> ErrInitializeGenesisAbsent -> Bool)
-> Eq ErrInitializeGenesisAbsent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrInitializeGenesisAbsent -> ErrInitializeGenesisAbsent -> Bool
$c/= :: ErrInitializeGenesisAbsent -> ErrInitializeGenesisAbsent -> Bool
== :: ErrInitializeGenesisAbsent -> ErrInitializeGenesisAbsent -> Bool
$c== :: ErrInitializeGenesisAbsent -> ErrInitializeGenesisAbsent -> Bool
Eq, Int -> ErrInitializeGenesisAbsent -> FilePath -> FilePath
[ErrInitializeGenesisAbsent] -> FilePath -> FilePath
ErrInitializeGenesisAbsent -> FilePath
(Int -> ErrInitializeGenesisAbsent -> FilePath -> FilePath)
-> (ErrInitializeGenesisAbsent -> FilePath)
-> ([ErrInitializeGenesisAbsent] -> FilePath -> FilePath)
-> Show ErrInitializeGenesisAbsent
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [ErrInitializeGenesisAbsent] -> FilePath -> FilePath
$cshowList :: [ErrInitializeGenesisAbsent] -> FilePath -> FilePath
show :: ErrInitializeGenesisAbsent -> FilePath
$cshow :: ErrInitializeGenesisAbsent -> FilePath
showsPrec :: Int -> ErrInitializeGenesisAbsent -> FilePath -> FilePath
$cshowsPrec :: Int -> ErrInitializeGenesisAbsent -> FilePath -> FilePath
Show)

instance Exception ErrInitializeGenesisAbsent