From 977ea266f1b516be9ec11c262c6b594e59eef620 Mon Sep 17 00:00:00 2001 From: Rodney Lorrimar Date: Mon, 20 May 2019 17:06:40 +1000 Subject: [PATCH] Sqlite: add checkpoints and transactions to DBLayer --- lib/core/src/Cardano/Wallet/DB/Sqlite.hs | 385 +++++++++++++++++- lib/core/src/Cardano/Wallet/DB/Sqlite/TH.hs | 70 +++- .../src/Cardano/Wallet/DB/Sqlite/Types.hs | 38 ++ .../Wallet/Primitive/AddressDerivation.hs | 3 +- .../Wallet/Primitive/AddressDiscovery.hs | 3 + .../src/Cardano/Wallet/Primitive/Model.hs | 1 + .../test/unit/Cardano/Wallet/DB/SqliteSpec.hs | 66 ++- lib/core/test/unit/Cardano/Wallet/DBSpec.hs | 11 +- 8 files changed, 555 insertions(+), 22 deletions(-) diff --git a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs index 2c40dc49ec0..3aa6cc24164 100644 --- a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs @@ -1,7 +1,10 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} -- | -- Copyright: © 2018-2019 IOHK @@ -23,10 +26,14 @@ import Cardano.Wallet.DB , ErrWalletAlreadyExists (..) , PrimaryKey (..) ) +import Cardano.Wallet.DB.Sqlite.Types + ( AddressPoolXPub (..), TxId (..) ) import Cardano.Wallet.Primitive.AddressDerivation ( Depth (..), deserializeXPrv, serializeXPrv ) import Conduit ( runResourceT ) +import Control.DeepSeq + ( NFData ) import Control.Monad ( void ) import Control.Monad.Catch @@ -35,26 +42,43 @@ import Control.Monad.IO.Class ( MonadIO (..) ) import Control.Monad.Logger ( LogLevel (..), runNoLoggingT ) +import Control.Monad.Trans.Class + ( lift ) import Control.Monad.Trans.Except ( ExceptT (..) ) +import Control.Monad.Trans.Maybe + ( MaybeT (..) ) +import Data.Bifunctor + ( bimap ) import Data.Coerce ( coerce ) import Data.Generics.Internal.VL.Lens ( (^.) ) +import Data.Quantity + ( Quantity (..) ) import Data.Text ( Text ) +import Data.Typeable + ( Typeable ) import Database.Persist.Sql - ( LogFunc + ( Entity (..) + , LogFunc + , SelectOpt (..) , Update (..) , deleteCascadeWhere , deleteWhere - , entityVal + , insert + , insertMany_ , insert_ + , putMany , runMigration , runSqlConn , selectFirst , selectKeysList + , selectList , updateWhere + , (/<-.) + , (<-.) , (=.) , (==.) ) @@ -70,8 +94,12 @@ import System.Log.FastLogger import Cardano.Wallet.DB.Sqlite.TH import qualified Cardano.Wallet.Primitive.AddressDerivation as W +import qualified Cardano.Wallet.Primitive.AddressDiscovery as W +import qualified Cardano.Wallet.Primitive.Model as W import qualified Cardano.Wallet.Primitive.Types as W import qualified Data.ByteString.Char8 as B8 +import qualified Data.Map as Map +import qualified Data.Set as Set import qualified Data.Text as T import qualified Database.Sqlite as Sqlite @@ -122,7 +150,8 @@ handleConstraint e = handleJust select handler . fmap Right -- If the given file path does not exist, it will be created by the sqlite -- library. newDBLayer - :: Maybe FilePath + :: forall s t. (W.IsOurs s, NFData s, Show s, PersistState s, W.TxId t) + => Maybe FilePath -- ^ Database file location, or Nothing for in-memory database -> IO (DBLayer IO s t) newDBLayer fp = do @@ -134,15 +163,22 @@ newDBLayer fp = do Wallets -----------------------------------------------------------------------} - { createWallet = \(PrimaryKey wid) _cp meta -> + { createWallet = \(PrimaryKey wid) cp meta -> ExceptT $ runQuery conn $ - handleConstraint (ErrWalletAlreadyExists wid) $ - insert_ (mkWalletEntity wid meta) + handleConstraint (ErrWalletAlreadyExists wid) $ do + insert_ (mkWalletEntity wid meta) + insertCheckpoint wid cp , removeWallet = \(PrimaryKey wid) -> ExceptT $ runQuery conn $ selectWallet wid >>= \case - Just _ -> Right <$> deleteCascadeWhere [WalTableId ==. wid] + Just _ -> Right <$> do + -- fixme: deleteCascade is not working with persistent-sqlite. + -- Therefore we need to delete related entities as well. + deleteCheckpoints wid + deleteState @s wid + deleteLooseTransactions wid + deleteCascadeWhere [WalTableId ==. wid] Nothing -> pure $ Left $ ErrNoSuchWallet wid , listWallets = runQuery conn $ @@ -152,9 +188,23 @@ newDBLayer fp = do Checkpoints -----------------------------------------------------------------------} - , putCheckpoint = \(PrimaryKey _wid) _cp -> error "unimplemented" + , putCheckpoint = \(PrimaryKey wid) cp -> + ExceptT $ runQuery conn $ Right <$> do + deleteCheckpoints wid -- clear out all checkpoints + deleteState @s wid -- clear state + deleteLooseTransactions wid -- clear transactions + insertCheckpoint wid cp -- add this checkpoint - , readCheckpoint = \(PrimaryKey _wid) -> error "unimplemented" + , readCheckpoint = \(PrimaryKey wid) -> + runQuery conn $ + selectLatestCheckpoint wid >>= \case + Just cp -> do + utxo <- selectUTxO cp + pendings <- selectPending cp + (ins, outs) <- selectTxs pendings + s <- selectState (checkpointId cp) + pure (checkpointFromEntity cp utxo ins outs <$> s) + Nothing -> pure Nothing {----------------------------------------------------------------------- Wallet Metadata @@ -178,9 +228,19 @@ newDBLayer fp = do Tx History -----------------------------------------------------------------------} - , putTxHistory = \(PrimaryKey _wid) _txs -> error "unimplemented" + , putTxHistory = \(PrimaryKey wid) txs -> + ExceptT $ runQuery conn $ + selectWallet wid >>= \case + Just _ -> do + let (metas, txins, txouts) = mkTxHistory wid txs + putMany metas + putMany txins + putMany txouts + pure $ Right () + Nothing -> pure $ Left $ ErrNoSuchWallet wid - , readTxHistory = \(PrimaryKey _wid) -> error "unimplemented" + , readTxHistory = \(PrimaryKey wid) -> runQuery conn $ + selectTxHistory wid {----------------------------------------------------------------------- Keystore @@ -264,8 +324,311 @@ privateKeyFromEntity -> Either String (W.Key 'RootK XPrv, W.Hash "encryption") privateKeyFromEntity (PrivateKey _ k h) = deserializeXPrv (k, h) +mkCheckpointEntity + :: forall s t. W.TxId t + => W.WalletId + -> W.Wallet s t + -> (Checkpoint, [UTxO], [PendingTx], [TxIn], [TxOut]) +mkCheckpointEntity wid wal = + ( cp, utxo, map (pendingTx . fst) pending + , concatMap (dist pendingTxIn . fmap W.inputs) pending + , concatMap (dist pendingTxOut . fmap (zip [0..] . W.outputs)) pending ) + where + pending = [(TxId (W.txId @t tx), tx) | tx <- Set.toList (W.getPending wal)] + sl = W.currentTip wal + cp = Checkpoint + { checkpointTableWalletId = wid + , checkpointTableSlot = sl + } + pendingTx tid = PendingTx + { pendingTxTableWalletId = wid + , pendingTxTableCheckpointSlot = sl + , pendingTxTableId2 = tid + } + pendingTxIn tid txIn = TxIn + { txInputTableTxId = tid + , txInputTableSourceTxId = TxId (W.inputId txIn) + , txInputTableSourceIndex = W.inputIx txIn + } + pendingTxOut tid (ix, txOut) = TxOut + { txOutputTableTxId = tid + , txOutputTableIndex = ix + , txOutputTableAddress = W.address txOut + , txOutputTableAmount = W.coin txOut + } + utxo = [ UTxO wid sl (TxId input) ix addr coin + | (W.TxIn input ix, W.TxOut addr coin) <- utxoMap ] + utxoMap = Map.assocs (W.getUTxO (W.totalUTxO wal)) + +-- inputs and outputs must be sorted by txid, then ix +checkpointFromEntity + :: forall s t. (W.IsOurs s, NFData s, Show s, W.TxId t) + => Checkpoint + -> [UTxO] + -> [TxIn] + -> [TxOut] + -> s + -> W.Wallet s t +checkpointFromEntity (Checkpoint _ tip) utxo ins outs = + W.Wallet utxo' pending tip + where + utxo' = W.UTxO . Map.fromList $ + [ (W.TxIn input ix, W.TxOut addr coin) + | UTxO _ _ (TxId input) ix addr coin <- utxo ] + ins' = [(txid, W.TxIn src ix) | TxIn txid (TxId src) ix <- ins] + outs' = [ (txid, W.TxOut addr amt) + | TxOut txid _ix addr amt <- outs ] + txids = Set.fromList $ map fst ins' ++ map fst outs' + pending = flip Set.map txids $ \txid -> W.Tx + { W.inputs = lookupTx txid ins' + , W.outputs = lookupTx txid outs' + } + lookupTx txid = map snd . filter ((== txid) . fst) + +mkTxHistory + :: W.WalletId + -> Map.Map (W.Hash "Tx") (W.Tx, W.TxMeta) + -> ([TxMeta], [TxIn], [TxOut]) +mkTxHistory wid txs = + ( map (uncurry (mkTxMetaEntity wid)) metas + , concatMap (dist mkTxIn . fmap W.inputs) hist + , concatMap (dist mkTxOut . fmap (zip [0..] . W.outputs)) hist ) + where + pairs = Map.toList txs + metas = fmap snd <$> pairs + hist = bimap TxId fst <$> pairs + mkTxIn tid txIn = TxIn + { txInputTableTxId = tid + , txInputTableSourceTxId = TxId (W.inputId txIn) + , txInputTableSourceIndex = W.inputIx txIn + } + mkTxOut tid (ix, txOut) = TxOut + { txOutputTableTxId = tid + , txOutputTableIndex = ix + , txOutputTableAddress = W.address txOut + , txOutputTableAmount = W.coin txOut + } + +mkTxMetaEntity :: W.WalletId -> W.Hash "Tx" -> W.TxMeta -> TxMeta +mkTxMetaEntity wid txid meta = TxMeta + { txMetaTableTxId = TxId txid + , txMetaTableWalletId = wid + , txMetaTableStatus = meta ^. #status + , txMetaTableDirection = meta ^. #direction + , txMetaTableSlotId = meta ^. #slotId + , txMetaTableAmount = getAmount (meta ^. #amount) + } + where getAmount (Quantity n) = n + +-- note: TxOut records must already be sorted by index +txHistoryFromEntity + :: [TxMeta] + -> [TxIn] + -> [TxOut] + -> Map.Map (W.Hash "Tx") (W.Tx, W.TxMeta) +txHistoryFromEntity metas ins outs = Map.fromList + [ (getTxId (txMetaTableTxId m), (mkTx (txMetaTableTxId m), mkTxMeta m)) + | m <- metas ] + where + mkTx txid = W.Tx + { W.inputs = map mkTxIn $ filter ((== txid) . txInputTableTxId) ins + , W.outputs = map mkTxOut $ filter ((== txid) . txOutputTableTxId) outs + } + mkTxIn tx = W.TxIn + { W.inputId = getTxId (txInputTableSourceTxId tx) + , W.inputIx = txInputTableSourceIndex tx + } + mkTxOut tx = W.TxOut + { W.address = txOutputTableAddress tx + , W.coin = txOutputTableAmount tx + } + mkTxMeta m = W.TxMeta + { W.status = txMetaTableStatus m + , W.direction = txMetaTableDirection m + , W.slotId = txMetaTableSlotId m + , W.amount = Quantity (txMetaTableAmount m) + } + ---------------------------------------------------------------------------- -- DB Queries selectWallet :: MonadIO m => W.WalletId -> SqlPersistT m (Maybe Wallet) selectWallet wid = fmap entityVal <$> selectFirst [WalTableId ==. wid] [] + +insertCheckpoint + :: (PersistState s, W.TxId t) + => W.WalletId + -> W.Wallet s t + -> SqlPersistM () +insertCheckpoint wid cp = do + let (cp', utxo, pendings, ins, outs) = mkCheckpointEntity wid cp + insert_ cp' + insertMany_ ins + insertMany_ outs + insertMany_ pendings + insertMany_ utxo + insertState (wid, W.currentTip cp) (W.getState cp) + +-- | Delete all checkpoints associated with a wallet. +deleteCheckpoints + :: W.WalletId + -> SqlPersistM () +deleteCheckpoints wid = do + deleteWhere [UtxoTableWalletId ==. wid] + deleteWhere [PendingTxTableWalletId ==. wid] + deleteWhere [CheckpointTableWalletId ==. wid] + +-- | Delete transactions that belong to a wallet and aren't referred to by +-- either Pending or TxMeta. +deleteLooseTransactions + :: W.WalletId + -> SqlPersistM () +deleteLooseTransactions wid = do + pendingTxId <- fmap (pendingTxTableId2 . entityVal) <$> + selectList [PendingTxTableWalletId ==. wid] [] + metaTxId <- fmap (txMetaTableTxId . entityVal) <$> + selectList [TxMetaTableWalletId ==. wid] [] + deleteWhere [ TxInputTableTxId /<-. pendingTxId + , TxInputTableTxId /<-. metaTxId ] + deleteWhere [ TxOutputTableTxId /<-. pendingTxId + , TxOutputTableTxId /<-. metaTxId ] + +selectLatestCheckpoint + :: W.WalletId + -> SqlPersistM (Maybe Checkpoint) +selectLatestCheckpoint wid = fmap entityVal <$> + selectFirst [CheckpointTableWalletId ==. wid] + [LimitTo 1, Desc CheckpointTableSlot] + +selectUTxO + :: Checkpoint + -> SqlPersistM [UTxO] +selectUTxO (Checkpoint wid sl) = fmap entityVal <$> + selectList [UtxoTableWalletId ==. wid, UtxoTableCheckpointSlot ==. sl] [] + +selectPending + :: Checkpoint + -> SqlPersistM [TxId] +selectPending (Checkpoint wid sl) = fmap (pendingTxTableId2 . entityVal) <$> + selectList [ PendingTxTableWalletId ==. wid + , PendingTxTableCheckpointSlot ==. sl ] [] + +selectTxs + :: [TxId] + -> SqlPersistM ([TxIn], [TxOut]) +selectTxs txids = do + ins <- fmap entityVal <$> selectList [TxInputTableTxId <-. txids] + [Asc TxInputTableTxId, Asc TxInputTableSourceIndex] + outs <- fmap entityVal <$> selectList [TxOutputTableTxId <-. txids] + [Asc TxOutputTableTxId, Asc TxOutputTableIndex] + pure (ins, outs) + +selectTxHistory + :: W.WalletId + -> SqlPersistM (Map.Map (W.Hash "Tx") (W.Tx, W.TxMeta)) +selectTxHistory wid = do + metas <- fmap entityVal <$> selectList [TxMetaTableWalletId ==. wid] [] + let txids = map txMetaTableTxId metas + ins <- fmap entityVal <$> selectList [TxInputTableTxId <-. txids] + [Asc TxInputTableTxId, Asc TxInputTableSourceIndex] + outs <- fmap entityVal <$> selectList [TxOutputTableTxId <-. txids] + [Asc TxOutputTableTxId, Asc TxOutputTableIndex] + pure $ txHistoryFromEntity metas ins outs + +--------------------------------------------------------------------------- +-- DB queries for address discovery state + +-- | Get a @(WalletId, SlotId)@ pair from the checkpoint table, for use with +-- 'insertState' and 'selectState'. +checkpointId :: Checkpoint -> (W.WalletId, W.SlotId) +checkpointId cp = (checkpointTableWalletId cp, checkpointTableSlot cp) + +-- | Functions for saving/loading the wallet's address discovery state into +-- SQLite. +class PersistState s where + -- | Store the state for a checkpoint. + insertState :: (W.WalletId, W.SlotId) -> s -> SqlPersistM () + -- | Load the state for a checkpoint. + selectState :: (W.WalletId, W.SlotId) -> SqlPersistM (Maybe s) + -- | Remove the state for all checkpoints of a wallet. + deleteState :: W.WalletId -> SqlPersistM () + +instance W.KeyToAddress t => PersistState (W.SeqState t) where + insertState (wid, sl) st = do + ssid <- insert (SeqState wid sl) + intApId <- insertAddressPool $ W.internalPool st + extApId <- insertAddressPool $ W.externalPool st + insert_ $ SeqStateInternalPool ssid intApId + insert_ $ SeqStateExternalPool ssid extApId + insertMany_ $ mkSeqStatePendingIxs ssid $ W.pendingChangeIxs st + + selectState (wid, sl) = runMaybeT $ do + ssid <- MaybeT $ fmap entityKey <$> + selectFirst [ SeqStateTableWalletId ==. wid + , SeqStateTableCheckpointSlot ==. sl ] [] + intApId <- MaybeT $ + fmap (seqStateInternalPoolAddressPool . entityVal) <$> + selectFirst [ SeqStateInternalPoolSeqStateId ==. ssid ] [] + extApId <- MaybeT $ + fmap (seqStateExternalPoolAddressPool . entityVal) <$> + selectFirst [ SeqStateExternalPoolSeqStateId ==. ssid ] [] + internalPool <- MaybeT $ selectAddressPool intApId + externalPool <- MaybeT $ selectAddressPool extApId + pendingChangeIxs <- lift $ selectSeqStatePendingIxs ssid + pure $ W.SeqState internalPool externalPool pendingChangeIxs + + deleteState wid = do + -- fixme: cascading delete not working with persistent-sqlite + deleteCascadeWhere [SeqStateTableWalletId ==. wid] + +insertAddressPool + :: W.AddressPool t c + -> SqlPersistM AddressPoolId +insertAddressPool ap = do + let ap' = AddressPool (AddressPoolXPub $ W.accountPubKey ap) (W.gap ap) + apid <- insert ap' + insertMany_ [ AddressPoolIndex apid a (W.getIndex i) + | (a, i) <- Map.toList (W.indexedAddresses ap) ] + pure apid + +mkSeqStatePendingIxs :: SeqStateId -> W.PendingIxs -> [SeqStatePendingIx] +mkSeqStatePendingIxs ssid (W.PendingIxs ixs) = + [SeqStatePendingIx ssid i (W.getIndex ix) | (i, ix) <- zip [0..] ixs] + +selectAddressPool + :: forall t chain. (W.KeyToAddress t, Typeable chain) + => AddressPoolId + -> SqlPersistM (Maybe (W.AddressPool t chain)) +selectAddressPool apid = do + ix <- fmap entityVal <$> selectList [IndexAddressPool ==. apid] + [Asc IndexNumber] + ap <- fmap entityVal <$> selectFirst [AddressPoolId ==. apid] [] + pure $ addressPoolFromEntity ix <$> ap + where + addressPoolFromEntity + :: [AddressPoolIndex] + -> AddressPool + -> W.AddressPool t chain + addressPoolFromEntity ixs (AddressPool (AddressPoolXPub pubKey) gap) = + ap { W.indexedAddresses = addrs } + where + ap = W.mkAddressPool @t @chain pubKey gap [] + addrs = Map.fromList + [(addr, W.Index ix) | AddressPoolIndex _ addr ix <- ixs] + +selectSeqStatePendingIxs :: SeqStateId -> SqlPersistM W.PendingIxs +selectSeqStatePendingIxs ssid = + fromRes <$> selectList + [SeqStatePendingIxSeqStateId ==. ssid] + [Asc SeqStatePendingIxPos] + where + fromRes = W.PendingIxs . fmap (W.Index . seqStatePendingIxIndex . entityVal) + +---------------------------------------------------------------------------- +-- Utilities + +-- | Distribute `a` accross many `b`s using the given function. +-- >>> dist TxOut (addr, [Coin 1, Coin 42, Coin 14]) +-- [TxOut addr (Coin 1), TxOut addr (Coin 42), TxOut addr (Coin 14)] +dist :: (a -> b -> c) -> (a, [b]) -> [c] +dist f (a, bs) = [f a b | b <- bs] diff --git a/lib/core/src/Cardano/Wallet/DB/Sqlite/TH.hs b/lib/core/src/Cardano/Wallet/DB/Sqlite/TH.hs index 03fc449c386..a755d494c1f 100644 --- a/lib/core/src/Cardano/Wallet/DB/Sqlite/TH.hs +++ b/lib/core/src/Cardano/Wallet/DB/Sqlite/TH.hs @@ -24,7 +24,7 @@ module Cardano.Wallet.DB.Sqlite.TH where import Prelude import Cardano.Wallet.DB.Sqlite.Types - ( TxId, sqlSettings' ) + ( AddressPoolXPub, TxId, sqlSettings' ) import Data.Text ( Text ) import Data.Time.Clock @@ -38,6 +38,7 @@ import GHC.Generics import Numeric.Natural ( Natural ) +import qualified Cardano.Wallet.Primitive.AddressDiscovery as W import qualified Cardano.Wallet.Primitive.Types as W import qualified Data.ByteString.Char8 as B8 @@ -152,4 +153,71 @@ UTxO sql=utxo Foreign Checkpoint fk_checkpoint_utxo utxoTableWalletId utxoTableCheckpointSlot deriving Show Generic + +-- The pending transactions for a wallet checkpoint. +PendingTx + + -- The wallet checkpoint (wallet_id, slot) + pendingTxTableWalletId W.WalletId sql=wallet_id + pendingTxTableCheckpointSlot W.SlotId sql=slot + + -- Transaction TxIn and TxOut + pendingTxTableId2 TxId sql=tx_id + + Primary pendingTxTableWalletId pendingTxTableCheckpointSlot pendingTxTableId2 + Foreign Checkpoint fk_pending_tx pendingTxTableWalletId pendingTxTableCheckpointSlot + deriving Show Generic + +-- State for sequential scheme address discovery +SeqState + + -- The wallet checkpoint (wallet_id, slot) + seqStateTableWalletId W.WalletId sql=wallet_id + seqStateTableCheckpointSlot W.SlotId sql=slot + + UniqueSeqState seqStateTableWalletId seqStateTableCheckpointSlot + Foreign Checkpoint fk_checkpoint_seq_state seqStateTableWalletId seqStateTableCheckpointSlot + deriving Show Generic + +-- Address pool attributes. +AddressPool + addressPoolAccountPubKey AddressPoolXPub + addressPoolGap W.AddressPoolGap + + deriving Show Generic + +-- Mapping of pool addresses to indices. +AddressPoolIndex + indexAddressPool AddressPoolId + indexAddress W.Address + indexNumber Word32 + + deriving Show Generic + +-- Sequential address discovery scheme -- internal address pool +-- associated with state record. +SeqStateInternalPool + seqStateInternalPoolSeqStateId SeqStateId + seqStateInternalPoolAddressPool AddressPoolId + UniqueSeqStateInternalPool seqStateInternalPoolSeqStateId seqStateInternalPoolAddressPool + Primary seqStateInternalPoolSeqStateId + deriving Show Generic + +-- Sequential address discovery scheme -- external address pool +-- associated with state record. +SeqStateExternalPool + seqStateExternalPoolSeqStateId SeqStateId + seqStateExternalPoolAddressPool AddressPoolId + UniqueSeqStateExternalPool seqStateExternalPoolSeqStateId seqStateExternalPoolAddressPool + Primary seqStateExternalPoolSeqStateId + deriving Show Generic + +-- Sequential address discovery scheme -- pending change indexes +SeqStatePendingIx + seqStatePendingIxSeqStateId SeqStateId + seqStatePendingIxPos Word32 + seqStatePendingIxIndex Word32 + + Primary seqStatePendingIxSeqStateId seqStatePendingIxPos + deriving Show Generic |] diff --git a/lib/core/src/Cardano/Wallet/DB/Sqlite/Types.hs b/lib/core/src/Cardano/Wallet/DB/Sqlite/Types.hs index 219ac67029e..82463888556 100644 --- a/lib/core/src/Cardano/Wallet/DB/Sqlite/Types.hs +++ b/lib/core/src/Cardano/Wallet/DB/Sqlite/Types.hs @@ -20,6 +20,12 @@ module Cardano.Wallet.DB.Sqlite.Types where import Prelude +import Cardano.Crypto.Wallet + ( XPub ) +import Cardano.Wallet.Primitive.AddressDerivation + ( Depth (..), Key, deserializeXPub, serializeXPub ) +import Cardano.Wallet.Primitive.AddressDiscovery + ( AddressPoolGap (..), getAddressPoolGap, mkAddressPoolGap ) import Cardano.Wallet.Primitive.Types ( Address (..) , Coin (..) @@ -74,6 +80,7 @@ import Web.HttpApiData import Web.PathPieces ( PathPiece (..) ) +import qualified Data.ByteString.Char8 as B8 import qualified Data.Text as T ---------------------------------------------------------------------------- @@ -253,3 +260,34 @@ instance PersistField Address where instance PersistFieldSql Address where sqlType _ = sqlType (Proxy @Text) + +---------------------------------------------------------------------------- +-- AddressPoolGap + +instance PersistField AddressPoolGap where + toPersistValue = toPersistValue . getAddressPoolGap + fromPersistValue pv = fromPersistValue >=> mkAddressPoolGap' $ pv + where + mkAddressPoolGap' :: Word8 -> Either Text AddressPoolGap + mkAddressPoolGap' = first msg . mkAddressPoolGap . fromIntegral + msg e = T.pack $ "not a valid value: " <> show pv <> ": " <> show e + +instance PersistFieldSql AddressPoolGap where + sqlType _ = sqlType (Proxy @Word8) + +---------------------------------------------------------------------------- +-- XPub for sequential address discovery + +newtype AddressPoolXPub = AddressPoolXPub + { getAddressPoolXPub :: Key 'AccountK XPub } + deriving (Show, Eq, Generic) + +instance PersistField AddressPoolXPub where + toPersistValue = toPersistValue . serializeXPub . getAddressPoolXPub + fromPersistValue pv = fromPersistValue >=> deserializeXPub' $ pv + where + deserializeXPub' = bimap msg AddressPoolXPub . deserializeXPub + msg e = T.pack $ "not a valid XPub: " <> show pv <> ": " <> e + +instance PersistFieldSql AddressPoolXPub where + sqlType _ = sqlType (Proxy @B8.ByteString) diff --git a/lib/core/src/Cardano/Wallet/Primitive/AddressDerivation.hs b/lib/core/src/Cardano/Wallet/Primitive/AddressDerivation.hs index 0254ad2d1e9..446268d486a 100644 --- a/lib/core/src/Cardano/Wallet/Primitive/AddressDerivation.hs +++ b/lib/core/src/Cardano/Wallet/Primitive/AddressDerivation.hs @@ -31,7 +31,8 @@ module Cardano.Wallet.Primitive.AddressDerivation , getKey , Depth (..) , Index - , getIndex + (..) -- fixme: internal constructor + -- , getIndex , DerivationType (..) , publicKey , digest diff --git a/lib/core/src/Cardano/Wallet/Primitive/AddressDiscovery.hs b/lib/core/src/Cardano/Wallet/Primitive/AddressDiscovery.hs index 9beade9c717..d81917d4a18 100644 --- a/lib/core/src/Cardano/Wallet/Primitive/AddressDiscovery.hs +++ b/lib/core/src/Cardano/Wallet/Primitive/AddressDiscovery.hs @@ -45,8 +45,11 @@ module Cardano.Wallet.Primitive.AddressDiscovery , mkAddressPool , lookupAddress + , indexedAddresses -- fixme: internal + -- * Pending Change Indexes , PendingIxs + (..) -- fixme: internal , emptyPendingIxs -- ** State diff --git a/lib/core/src/Cardano/Wallet/Primitive/Model.hs b/lib/core/src/Cardano/Wallet/Primitive/Model.hs index 2737b293460..b8b8c070c13 100644 --- a/lib/core/src/Cardano/Wallet/Primitive/Model.hs +++ b/lib/core/src/Cardano/Wallet/Primitive/Model.hs @@ -29,6 +29,7 @@ module Cardano.Wallet.Primitive.Model ( -- * Type Wallet + (..) -- fixme: internal -- * Construction & Modification , initWallet diff --git a/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs b/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs index 8dd4bf6a611..a5528147037 100644 --- a/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -17,11 +18,31 @@ import Cardano.Wallet.DB import Cardano.Wallet.DB.Sqlite ( newDBLayer ) import Cardano.Wallet.DBSpec - ( cleanDB ) + ( DummyTarget, cleanDB ) import Cardano.Wallet.Primitive.AddressDerivation - ( encryptPassphrase, unsafeGenerateKeyFromSeed ) + ( Passphrase (..) + , encryptPassphrase + , generateKeyFromSeed + , unsafeGenerateKeyFromSeed + ) +import Cardano.Wallet.Primitive.AddressDiscovery + ( SeqState, defaultAddressPoolGap, mkSeqState ) +import Cardano.Wallet.Primitive.Mnemonic + ( EntropySize, entropyToBytes, genEntropy ) +import Cardano.Wallet.Primitive.Model + ( Wallet, initWallet ) import Cardano.Wallet.Primitive.Types - ( WalletDelegation (..) + ( Address (..) + , Coin (..) + , Direction (..) + , Hash (..) + , SlotId (..) + , Tx (..) + , TxIn (..) + , TxMeta (TxMeta) + , TxOut (..) + , TxStatus (..) + , WalletDelegation (..) , WalletId (..) , WalletMetadata (..) , WalletName (..) @@ -36,33 +57,39 @@ import Data.ByteString ( ByteString ) import Data.Coerce ( coerce ) +import Data.Quantity + ( Quantity (..) ) import Data.Text.Class ( FromText (..) ) import Data.Time.Clock ( getCurrentTime ) +import System.IO.Unsafe + ( unsafePerformIO ) import Test.Hspec ( Spec, beforeAll, beforeWith, describe, it, shouldReturn ) +import qualified Data.Map as Map + spec :: Spec -spec = beforeAll (newDBLayer Nothing) $ beforeWith cleanDB $ do +spec = beforeAll newMemoryDBLayer $ beforeWith cleanDB $ do describe "Wallet table" $ do it "create and list works" $ \db -> do - unsafeRunExceptT $ createWallet db testPk undefined testMetadata + unsafeRunExceptT $ createWallet db testPk testCp testMetadata listWallets db `shouldReturn` [testPk] it "create and get meta works" $ \db -> do now <- getCurrentTime let md = testMetadata { passphraseInfo = Just $ WalletPassphraseInfo now } - unsafeRunExceptT $ createWallet db testPk undefined md + unsafeRunExceptT $ createWallet db testPk testCp md readWalletMeta db testPk `shouldReturn` Just md it "create twice is handled" $ \db -> do - let create' = createWallet db testPk undefined testMetadata + let create' = createWallet db testPk testCp testMetadata runExceptT create' `shouldReturn` (Right ()) runExceptT create' `shouldReturn` (Left (ErrWalletAlreadyExists testWid)) it "create and get private key" $ \db -> do - unsafeRunExceptT $ createWallet db testPk undefined testMetadata + unsafeRunExceptT $ createWallet db testPk testCp testMetadata readPrivateKey db testPk `shouldReturn` Nothing let Right phr = fromText "aaaaaaaaaa" k = unsafeGenerateKeyFromSeed (coerce phr, coerce phr) phr @@ -70,6 +97,23 @@ spec = beforeAll (newDBLayer Nothing) $ beforeWith cleanDB $ do unsafeRunExceptT (putPrivateKey db testPk (k, h)) readPrivateKey db testPk `shouldReturn` Just (k, h) + it "put and read tx history" $ \db -> do + unsafeRunExceptT $ createWallet db testPk testCp testMetadata + runExceptT (putTxHistory db testPk testTxs) `shouldReturn` Right () + readTxHistory db testPk `shouldReturn` testTxs + +newMemoryDBLayer :: IO (DBLayer IO (SeqState DummyTarget) DummyTarget) +newMemoryDBLayer = newDBLayer Nothing + +testCp :: Wallet (SeqState DummyTarget) DummyTarget +testCp = initWallet initDummyState + +initDummyState :: SeqState DummyTarget +initDummyState = mkSeqState (xprv, mempty) defaultAddressPoolGap + where + bytes = entropyToBytes <$> unsafePerformIO $ genEntropy @(EntropySize 15) + xprv = generateKeyFromSeed (Passphrase bytes, mempty) mempty + testMetadata :: WalletMetadata testMetadata = WalletMetadata { name = WalletName "test wallet" @@ -83,3 +127,9 @@ testWid = WalletId (hash ("test" :: ByteString)) testPk :: PrimaryKey WalletId testPk = PrimaryKey testWid + +testTxs :: Map.Map (Hash "Tx") (Tx, TxMeta) +testTxs = Map.fromList + [ (Hash "tx2" + , (Tx [TxIn (Hash "tx1") 0] [TxOut (Address "addr") (Coin 1)] + , TxMeta InLedger Incoming (SlotId 14 0) (Quantity 1337144))) ] diff --git a/lib/core/test/unit/Cardano/Wallet/DBSpec.hs b/lib/core/test/unit/Cardano/Wallet/DBSpec.hs index 27b9908436e..6a2d0da1efc 100644 --- a/lib/core/test/unit/Cardano/Wallet/DBSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/DBSpec.hs @@ -30,7 +30,13 @@ import Cardano.Wallet.DB , PrimaryKey (..) ) import Cardano.Wallet.Primitive.AddressDerivation - ( Depth (..), Key, Passphrase (..), XPrv, generateKeyFromSeed ) + ( Depth (..) + , Key + , KeyToAddress (..) + , Passphrase (..) + , XPrv + , generateKeyFromSeed + ) import Cardano.Wallet.Primitive.AddressDiscovery ( IsOurs (..) ) import Cardano.Wallet.Primitive.Model @@ -150,6 +156,9 @@ data DummyTarget instance TxId DummyTarget where txId = Hash . B8.pack . show +instance KeyToAddress DummyTarget where + keyToAddress _ = Address "" + instance Arbitrary (PrimaryKey WalletId) where shrink _ = [] arbitrary = do