Mark addresses as used while discovering them.

lib/core/src/Cardano/Wallet.hs

@@ -13,6 +13,7 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
@@ -99,6 +100,7 @@ module Cardano.Wallet
     , normalizeDelegationAddress
     , ErrCreateRandomAddress(..)
     , ErrImportRandomAddress(..)
+    , ErrImportAddress(..)
 
     -- ** Payment
     , selectCoinsExternal
@@ -235,7 +237,7 @@ import Cardano.Wallet.Primitive.AddressDiscovery
     , KnownAddresses (..)
     )
 import Cardano.Wallet.Primitive.AddressDiscovery.Random
-    ( RndState )
+    ( ErrImportAddress (..), RndState )
 import Cardano.Wallet.Primitive.AddressDiscovery.Sequential
     ( SeqState
     , defaultAddressPoolGap
@@ -752,7 +754,8 @@ restoreWallet ctx wid = db & \DBLayer{..} -> do
             restoreBlocks @ctx @s @k @t ctx wid bs h
             saveParams @ctx @s @k ctx wid ps
     liftIO (follow nw tr cps forward (view #header)) >>= \case
-        FollowInterrupted -> pure ()
+        FollowInterrupted ->
+            pure ()
         FollowFailure ->
             restoreWallet @ctx @s @t @k ctx wid
         FollowRollback point -> do
@@ -1044,7 +1047,6 @@ manageRewardBalance _ ctx wid = db & \DBLayer{..} -> do
 listAddresses
     :: forall ctx s k.
         ( HasDBLayer s k ctx
-        , IsOurs s Address
         , CompareDiscovery s
         , KnownAddresses s
         )
@@ -1057,25 +1059,19 @@ listAddresses
         -- Use 'Just' for wallet without delegation settings.
     -> ExceptT ErrNoSuchWallet IO [(Address, AddressState)]
 listAddresses ctx wid normalize = db & \DBLayer{..} -> do
-    (s, txs) <- mapExceptT atomically $ (,)
-        <$> (getState <$> withNoSuchWallet wid (readCheckpoint primaryKey))
-        <*> lift (readTxHistory primaryKey Nothing Descending wholeRange Nothing)
-    let maybeIsOurs (TxOut a _) = if fst (isOurs a s)
-            then normalize s a
-            else Nothing
-    let usedAddrs
-            = Set.fromList
-            $ concatMap
-                (mapMaybe maybeIsOurs . W.outputs)
-                (fromTransactionInfo <$> txs)
-    let knownAddrs =
-            L.sortBy (compareDiscovery s) (mapMaybe (normalize s) $ knownAddresses s)
-    let withAddressState addr =
-            (addr, if addr `Set.member` usedAddrs then Used else Unused)
-    return $ withAddressState <$> knownAddrs
+    cp <- mapExceptT atomically
+        $ withNoSuchWallet wid
+        $ readCheckpoint (PrimaryKey wid)
+    let s = getState cp
+
+    -- FIXME
+    -- Stream this instead of returning it as a single block.
+    return
+        $ L.sortBy (\(a,_) (b,_) -> compareDiscovery s a b)
+        $ mapMaybe (\(addr, st) -> (,st) <$> normalize s addr)
+        $ knownAddresses s
   where
     db = ctx ^. dbLayer @s @k
-    primaryKey = PrimaryKey wid
 
 createChangeAddress
     :: forall ctx s k.
@@ -1126,7 +1122,7 @@ createRandomAddress ctx wid pwd mIx = db & \DBLayer{..} ->
 
             let prepared = preparePassphrase scheme pwd
             let addr = Rnd.deriveRndStateAddress @n xprv prepared path
-            let s' = (Rnd.addDiscoveredAddress addr path s) { Rnd.gen = gen' }
+            let s' = (Rnd.addDiscoveredAddress addr Unused path s) { Rnd.gen = gen' }
             withExceptT ErrCreateAddrNoSuchWallet $
                 putCheckpoint (PrimaryKey wid) (updateState s' cp)
             pure addr
@@ -1148,12 +1144,13 @@ importRandomAddresses
 importRandomAddresses ctx wid addrs = db & \DBLayer{..} -> mapExceptT atomically $ do
     cp <- withExceptT ErrImportAddrNoSuchWallet
         $ withNoSuchWallet wid (readCheckpoint (PrimaryKey wid))
-    let s = getState cp
-        ours = scanl' (\(_, t) addr -> isOurs addr t) (True, s) addrs
-        s' = snd (last ours)
-    if (not . any fst) ours
-        then throwE ErrImportAddrDoesNotBelong
-        else withExceptT ErrImportAddrNoSuchWallet $
+    let s0 = getState cp
+        ours = scanl' (\s addr -> s >>= Rnd.importAddress addr) (Right s0) addrs
+    case last ours of
+        Left err ->
+            throwE $ ErrImportAddr err
+        Right s' ->
+            withExceptT ErrImportAddrNoSuchWallet $
                 putCheckpoint (PrimaryKey wid) (updateState s' cp)
   where
     db = ctx ^. dbLayer @s @k
@@ -2292,7 +2289,7 @@ data ErrCreateRandomAddress
 
 data ErrImportRandomAddress
     = ErrImportAddrNoSuchWallet ErrNoSuchWallet
-    | ErrImportAddrDoesNotBelong
+    | ErrImportAddr ErrImportAddress
     | ErrImportAddressNotAByronWallet
     deriving (Generic, Eq, Show)
 

lib/core/src/Cardano/Wallet/Api/Server.hs

@@ -106,6 +106,7 @@ import Cardano.Wallet
     , ErrDecodeSignedTx (..)
     , ErrFetchRewards (..)
     , ErrGetTransaction (..)
+    , ErrImportAddress (..)
     , ErrImportRandomAddress (..)
     , ErrJoinStakePool (..)
     , ErrListTransactions (..)
@@ -1177,7 +1178,6 @@ putRandomAddresses ctx (ApiT wid) (ApiPutAddressesData addrs)  = do
 listAddresses
     :: forall ctx s t k n.
         ( ctx ~ ApiLayer s t k
-        , IsOurs s Address
         , CompareDiscovery s
         , KnownAddresses s
         )
@@ -2446,7 +2446,7 @@ instance LiftHandler ErrImportRandomAddress where
                 [ "I cannot derive new address for this wallet type."
                 , " Make sure to use Byron random wallet id."
                 ]
-        ErrImportAddrDoesNotBelong ->
+        ErrImportAddr ErrAddrDoesNotBelong{} ->
             apiError err403 KeyNotFoundForAddress $ mconcat
                 [ "I couldn't identify this address as one of mine. It likely "
                 , "belongs to another wallet and I will therefore not import it."

lib/core/src/Cardano/Wallet/DB/Sqlite.hs

@@ -325,6 +325,7 @@ data SqlColumnStatus
     = TableMissing
     | ColumnMissing
     | ColumnPresent
+    deriving Eq
 
 -- | Executes any manual database migration steps that may be required on
 --   startup.
@@ -352,6 +353,8 @@ migrateManually tr defaultFieldValues =
         removeSoftRndAddresses conn
 
         removeOldTxParametersTable conn
+
+        addAddressStateIfMissing conn
   where
     -- NOTE
     -- Wallets created before the 'PassphraseScheme' was introduced have no
@@ -436,7 +439,7 @@ migrateManually tr defaultFieldValues =
     --
     addActiveSlotCoefficientIfMissing :: Sqlite.Connection -> IO ()
     addActiveSlotCoefficientIfMissing conn =
-        addColumn conn True (DBField CheckpointActiveSlotCoeff) value
+        addColumn_ conn True (DBField CheckpointActiveSlotCoeff) value
       where
         value = toText
             $ W.unActiveSlotCoefficient
@@ -447,7 +450,7 @@ migrateManually tr defaultFieldValues =
     --
     addDesiredPoolNumberIfMissing :: Sqlite.Connection -> IO ()
     addDesiredPoolNumberIfMissing conn = do
-        addColumn conn True (DBField ProtocolParametersDesiredNumberOfPools) value
+        addColumn_ conn True (DBField ProtocolParametersDesiredNumberOfPools) value
       where
         value = T.pack $ show $ defaultDesiredNumberOfPool defaultFieldValues
 
@@ -456,7 +459,7 @@ migrateManually tr defaultFieldValues =
     --
     addMinimumUTxOValueIfMissing :: Sqlite.Connection -> IO ()
     addMinimumUTxOValueIfMissing conn = do
-        addColumn conn True (DBField ProtocolParametersMinimumUtxoValue) value
+        addColumn_ conn True (DBField ProtocolParametersMinimumUtxoValue) value
       where
         value = T.pack $ show $ W.getCoin $ defaultMinimumUTxOValue defaultFieldValues
 
@@ -465,7 +468,7 @@ migrateManually tr defaultFieldValues =
     --
     addHardforkEpochIfMissing :: Sqlite.Connection -> IO ()
     addHardforkEpochIfMissing conn = do
-        addColumn conn False (DBField ProtocolParametersHardforkEpoch) value
+        addColumn_ conn False (DBField ProtocolParametersHardforkEpoch) value
       where
         value = case defaultHardforkEpoch defaultFieldValues of
             Nothing -> "NULL"
@@ -478,6 +481,27 @@ migrateManually tr defaultFieldValues =
         void $ Sqlite.stepConn conn dropTable
         Sqlite.finalize dropTable
 
+    -- | In order to make listing addresses bearable for large wallet, we
+    -- altered the discovery process to mark addresses as used as they are
+    -- discovered. Existing databases don't have that pre-computed field.
+    addAddressStateIfMissing :: Sqlite.Connection -> IO ()
+    addAddressStateIfMissing conn = do
+        _  <- addColumn conn False (DBField SeqStateAddressStatus) (toText W.Unused)
+        st <- addColumn conn False (DBField RndStateAddressStatus) (toText W.Unused)
+        when (st == ColumnMissing) $ do
+            markAddressesAsUsed (DBField SeqStateAddressStatus)
+            markAddressesAsUsed (DBField RndStateAddressStatus)
+      where
+        markAddressesAsUsed field = do
+            query <- Sqlite.prepare conn $ T.unwords
+                [ "UPDATE", tableName field
+                , "SET status = '" <> toText W.Used <> "'"
+                , "WHERE", tableName field <> ".address", "IN"
+                , "(SELECT DISTINCT(address) FROM tx_out)"
+                ]
+            _ <- Sqlite.step query
+            Sqlite.finalize query
+
     -- | Determines whether a field is present in its parent table.
     isFieldPresent :: Sqlite.Connection -> DBField -> IO SqlColumnStatus
     isFieldPresent conn field = do
@@ -495,16 +519,25 @@ migrateManually tr defaultFieldValues =
                 | otherwise                       -> ColumnMissing
             _ -> TableMissing
 
+    addColumn_
+        :: Sqlite.Connection
+        -> Bool
+        -> DBField
+        -> Text
+        -> IO ()
+    addColumn_ a b c =
+        void . addColumn a b c
+
     -- | A migration for adding a non-existing column to a table. Factor out as
     -- it's a common use-case.
     addColumn
         :: Sqlite.Connection
         -> Bool
         -> DBField
         -> Text
-        -> IO ()
+        -> IO SqlColumnStatus
     addColumn conn notNull field value = do
-        isFieldPresent conn field >>= \case
+        isFieldPresent conn field >>= \st -> st <$ case st of
             TableMissing ->
                 traceWith tr $ MsgManualMigrationNotNeeded field
             ColumnMissing -> do
@@ -1496,8 +1529,9 @@ insertAddressPool
     -> SqlPersistT IO ()
 insertAddressPool wid sl pool =
     void $ dbChunked insertMany_
-        [ SeqStateAddress wid sl addr ix (Seq.accountingStyle @c)
-        | (ix, addr) <- zip [0..] (Seq.addresses (liftPaymentAddress @n) pool)
+        [ SeqStateAddress wid sl addr state ix (Seq.accountingStyle @c)
+        | (ix, (addr, state))
+        <- zip [0..] (Seq.addresses (liftPaymentAddress @n) pool)
         ]
 
 selectAddressPool
@@ -1523,8 +1557,9 @@ selectAddressPool wid sl gap xpub = do
     addressPoolFromEntity
         :: [SeqStateAddress]
         -> Seq.AddressPool c k
-    addressPoolFromEntity addrs =
-        Seq.mkAddressPool @n @c @k xpub gap (map seqStateAddressAddress addrs)
+    addressPoolFromEntity addrs
+        = Seq.mkAddressPool @n @c @k xpub gap
+        $ map (\x -> (seqStateAddressAddress x, seqStateAddressStatus x)) addrs
 
 mkSeqStatePendingIxs :: W.WalletId -> Seq.PendingIxs -> [SeqStatePendingIx]
 mkSeqStatePendingIxs wid =
@@ -1542,12 +1577,6 @@ selectSeqStatePendingIxs wid =
                           HD Random address discovery
 -------------------------------------------------------------------------------}
 
--- | Type alias for the index -> address map so that lines do not exceed 80
--- characters in width.
-type RndStateAddresses = Map
-    (W.Index 'W.WholeDomain 'W.AccountK, W.Index 'W.WholeDomain 'W.AddressK)
-    W.Address
-
 -- Persisting 'RndState' requires that the wallet root key has already been
 -- added to the database with 'putPrivateKey'. Unlike sequential AD, random
 -- address discovery requires a root key to recognize addresses.
@@ -1593,17 +1622,17 @@ instance PersistState (Rnd.RndState t) where
 insertRndStateAddresses
     :: W.WalletId
     -> W.SlotNo
-    -> RndStateAddresses
+    -> Map Rnd.DerivationPath (W.Address, W.AddressState)
     -> SqlPersistT IO ()
 insertRndStateAddresses wid sl addresses = do
     dbChunked insertMany_
-        [ RndStateAddress wid sl accIx addrIx addr
-        | ((W.Index accIx, W.Index addrIx), addr) <- Map.assocs addresses
+        [ RndStateAddress wid sl accIx addrIx addr st
+        | ((W.Index accIx, W.Index addrIx), (addr, st)) <- Map.assocs addresses
         ]
 
 insertRndStatePending
     :: W.WalletId
-    -> RndStateAddresses
+    -> Map Rnd.DerivationPath W.Address
     -> SqlPersistT IO ()
 insertRndStatePending wid addresses = do
     deleteWhere [RndStatePendingAddressWalletId ==. wid]
@@ -1615,20 +1644,20 @@ insertRndStatePending wid addresses = do
 selectRndStateAddresses
     :: W.WalletId
     -> W.SlotNo
-    -> SqlPersistT IO RndStateAddresses
+    -> SqlPersistT IO (Map Rnd.DerivationPath (W.Address, W.AddressState))
 selectRndStateAddresses wid sl = do
     addrs <- fmap entityVal <$> selectList
         [ RndStateAddressWalletId ==. wid
         , RndStateAddressSlot ==. sl
         ] []
     pure $ Map.fromList $ map assocFromEntity addrs
   where
-    assocFromEntity (RndStateAddress _ _ accIx addrIx addr) =
-        ((W.Index accIx, W.Index addrIx), addr)
+    assocFromEntity (RndStateAddress _ _ accIx addrIx addr st) =
+        ((W.Index accIx, W.Index addrIx), (addr, st))
 
 selectRndStatePending
     :: W.WalletId
-    -> SqlPersistT IO RndStateAddresses
+    -> SqlPersistT IO (Map Rnd.DerivationPath W.Address)
 selectRndStatePending wid = do
     addrs <- fmap entityVal <$> selectList
         [ RndStatePendingAddressWalletId ==. wid

lib/core/src/Cardano/Wallet/DB/Sqlite/TH.hs

@@ -239,10 +239,11 @@ SeqState
 -- Mapping of pool addresses to indices, and the slot
 -- when they were discovered.
 SeqStateAddress
-    seqStateAddressWalletId         W.WalletId     sql=wallet_id
-    seqStateAddressSlot             SlotNo         sql=slot
-    seqStateAddressAddress          W.Address      sql=address
-    seqStateAddressIndex            Word32         sql=address_ix
+    seqStateAddressWalletId         W.WalletId         sql=wallet_id
+    seqStateAddressSlot             SlotNo             sql=slot
+    seqStateAddressAddress          W.Address          sql=address
+    seqStateAddressStatus           W.AddressState     sql=status
+    seqStateAddressIndex            Word32             sql=address_ix
     seqStateAddressAccountingStyle  W.AccountingStyle  sql=accounting_style
 
     Primary
@@ -282,6 +283,7 @@ RndStateAddress
     rndStateAddressAccountIndex  Word32            sql=account_ix
     rndStateAddressIndex         Word32            sql=address_ix
     rndStateAddressAddress       W.Address         sql=address
+    rndStateAddressStatus        W.AddressState    sql=status
 
     Primary
         rndStateAddressWalletId

lib/core/src/Cardano/Wallet/DB/Sqlite/Types.hs

@@ -30,6 +30,7 @@ import Cardano.Wallet.Primitive.AddressDiscovery.Sequential
     ( AddressPoolGap (..), getAddressPoolGap, mkAddressPoolGap )
 import Cardano.Wallet.Primitive.Types
     ( Address (..)
+    , AddressState (..)
     , ChimericAccount (..)
     , Coin (..)
     , Direction (..)
@@ -536,7 +537,6 @@ instance PathPiece StakePoolMetadataUrl where
     fromPathPiece = fromTextMaybe
     toPathPiece = toText
 
-
 ----------------------------------------------------------------------------
 -- ChimericAccount
 
@@ -565,3 +565,13 @@ instance FromJSON ChimericAccount where
 instance PathPiece ChimericAccount where
     fromPathPiece = fromTextMaybe
     toPathPiece = toText
+
+----------------------------------------------------------------------------
+-- AddressState
+
+instance PersistField AddressState where
+    toPersistValue = toPersistValue . toText
+    fromPersistValue = fromPersistValueFromText
+
+instance PersistFieldSql AddressState where
+    sqlType _ = sqlType (Proxy @Text)