More measures post restoration benchmarks + SeqAnyState

.weeder.yaml

@@ -1,15 +1,5 @@
 - package:
   - name: cardano-wallet
-  - section:
-    - name: bench:restore
-    - message:
-      - name: Weeds exported
-      - module:
-        - name: Cardano.Wallet.Primitive.AddressDiscovery.Any.TH
-        - identifier:
-          - AnyAddressStateId
-          - AnyAddressStateKey
-          - AnyAddressStateProportion
   - section:
     - name: test:integration bench:latency
     - message:

lib/core-integration/src/Cardano/Wallet/BenchShared.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE LambdaCase #-}
 
 -- |
@@ -19,6 +20,7 @@ module Cardano.Wallet.BenchShared
     -- * Benchmark runner
     , runBenchmarks
     , bench
+    , Time
     ) where
 
 import Prelude
@@ -46,7 +48,7 @@ import Cardano.Wallet.Network.Ports
 import Control.Concurrent
     ( threadDelay )
 import Control.DeepSeq
-    ( rnf )
+    ( NFData, rnf )
 import Control.Exception
     ( evaluate )
 import Control.Monad
@@ -58,7 +60,9 @@ import Data.Functor
 import Data.Text
     ( Text )
 import Fmt
-    ( fmt, (+|), (|+) )
+    ( Buildable (..), nameF, pretty )
+import GHC.Generics
+    ( Generic )
 import Options.Applicative
     ( HasValue
     , Mod
@@ -204,28 +208,31 @@ getRestoreBenchArgs = do
                                 Benchmark runner
 -------------------------------------------------------------------------------}
 
-runBenchmarks :: [IO (Text, Double)] -> IO ()
+newtype Time = Time
+    { unTime :: Double
+    } deriving (Show, Generic)
+
+instance Buildable Time where
+    build = build . secs . unTime
+
+runBenchmarks :: Buildable a => [IO a] -> IO ()
 runBenchmarks bs = do
     initializeTime
     -- NOTE: Adding an artificial delay between successive runs to get a better
     -- output for the heap profiling.
     rs <- forM bs $ \io -> io <* let _2s = 2000000 in threadDelay _2s
     sayErr "\n\nAll results:"
-    mapM_ (uncurry printResult) rs
+    mapM_ (sayErr . pretty) rs
 
-bench :: Text -> IO () -> IO (Text, Double)
+bench :: NFData a => Text -> IO a -> IO (a, Time)
 bench benchName action = do
     sayErr $ "Running " <> benchName
     start <- getTime
     res <- action
     evaluate (rnf res)
     finish <- getTime
-    let dur = finish - start
-    printResult benchName dur
-    pure (benchName, dur)
-
-printResult :: Text -> Double -> IO ()
-printResult benchName dur = sayErr . fmt $ "  "+|benchName|+": "+|secs dur|+""
+    let t = Time $ finish - start
+    (res, t) <$ sayErr (pretty $ nameF (build benchName) (build t))
 
 initBenchmarkLogging :: Severity -> IO (CM.Configuration, Trace IO Text)
 initBenchmarkLogging minSeverity = do

lib/core/src/Cardano/Wallet.hs

@@ -331,6 +331,8 @@ import Cardano.Wallet.Transaction
     )
 import Cardano.Wallet.Unsafe
     ( unsafeXPrv )
+import Control.DeepSeq
+    ( NFData )
 import Control.Exception
     ( Exception, try )
 import Control.Monad
@@ -1988,7 +1990,9 @@ data FeeEstimation = FeeEstimation
     -- ^ Most coin selections will result in a fee higher than this.
     , estMaxFee :: Word64
     -- ^ Most coin selections will result in a fee lower than this.
-    } deriving (Show, Eq)
+    } deriving (Show, Eq, Generic)
+
+instance NFData FeeEstimation
 
 -- | Estimate the transaction fee for a given coin selection algorithm by
 -- repeatedly running it (100 times) and collecting the results. In the returned

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

@@ -1493,6 +1493,12 @@ class PersistState s where
                           Sequential address discovery
 -------------------------------------------------------------------------------}
 
+-- piggy-back on SeqState existing instance, to simulate the same behavior.
+instance PersistState (Seq.SeqState n k) => PersistState (Seq.SeqAnyState n k p)
+  where
+    insertState (wid, sl) = insertState (wid, sl) . Seq.innerState
+    selectState (wid, sl) = fmap Seq.SeqAnyState <$> selectState (wid, sl)
+
 instance
     ( Eq (k 'AccountK XPub)
     , PersistPublicKey (k 'AccountK)

lib/core/src/Cardano/Wallet/Primitive/AddressDiscovery/Random.hs

@@ -304,9 +304,9 @@ instance NFData (RndAnyState n p)
 -- | Initialize the HD random address discovery state from a root key and RNG
 -- seed.
 --
--- The type parameter is expected to be a ratio (between 0 and 100) of addresses
--- we ought to simply recognize as ours. So, giving @5 means that 5% of the
--- entire address space of the network will be considered ours, picked randomly.
+-- The type parameter is expected to be a ratio of addresses we ought to simply
+-- recognize as ours. It is expressed in tenths of percent, so "1" means 0.1%,
+-- "10" means 1% and 1000 means 100%.
 mkRndAnyState
     :: forall (p :: Nat) n. ()
     => ByronKey 'RootK XPrv
@@ -341,7 +341,7 @@ instance KnownNat p => IsOurs (RndAnyState n p) Address where
             (False, _) ->
                 (False, st)
       where
-        p = floor (double (maxBound :: Word32) * double (natVal (Proxy @p)) / 100)
+        p = floor (double (maxBound :: Word32) * double (natVal (Proxy @p)) / 1000)
 
         double :: Integral a => a -> Double
         double = fromIntegral
@@ -352,18 +352,12 @@ instance IsOurs (RndAnyState n p) ChimericAccount where
 instance KnownNat p => IsOwned (RndAnyState n p) ByronKey where
     isOwned _ _ _ = Nothing
 
-instance GenChange (RndAnyState n p) where
-    type ArgGenChange (RndAnyState n p) = ()
-    genChange _ = error
-        "GenChange.genChange: trying to generate change for \
-        \an incompatible scheme '(RndAnyState n p)'. Please don't."
+instance PaymentAddress n ByronKey => GenChange (RndAnyState n p) where
+    type ArgGenChange (RndAnyState n p) = ArgGenChange (RndState n)
+    genChange a (RndAnyState s) = RndAnyState <$> genChange a s
 
 instance CompareDiscovery (RndAnyState n p) where
-    compareDiscovery _ _ _ = error
-        "CompareDiscovery.compareDiscovery: trying to generate change for \
-        \an incompatible scheme '(RndAnyState n p)'. Please don't."
+    compareDiscovery (RndAnyState s) = compareDiscovery s
 
 instance KnownAddresses (RndAnyState n p) where
-    knownAddresses _ = error
-        "KnownAddresses.knownAddresses: trying to generate change for \
-        \an incompatible scheme '(RndAnyState n p)'. Please don't."
+    knownAddresses (RndAnyState s) = knownAddresses s

lib/core/src/Cardano/Wallet/Primitive/AddressDiscovery/Sequential.hs

@@ -57,6 +57,10 @@ module Cardano.Wallet.Primitive.AddressDiscovery.Sequential
     , SeqState (..)
     , mkSeqStateFromRootXPrv
     , mkSeqStateFromAccountXPub
+
+    -- ** Benchmarking
+    , SeqAnyState (..)
+    , mkSeqAnyState
     ) where
 
 import Prelude
@@ -87,7 +91,7 @@ import Cardano.Wallet.Primitive.AddressDiscovery
     , KnownAddresses (..)
     )
 import Cardano.Wallet.Primitive.Types
-    ( Address, AddressState (..), invariant )
+    ( Address (..), AddressState (..), ChimericAccount (..), invariant )
 import Control.Applicative
     ( (<|>) )
 import Control.DeepSeq
@@ -96,6 +100,8 @@ import Control.Monad
     ( unless )
 import Data.Bifunctor
     ( first )
+import Data.Digest.CRC32
+    ( crc32 )
 import Data.Function
     ( (&) )
 import Data.Map.Strict
@@ -118,6 +124,8 @@ import GHC.Generics
     ( Generic )
 import GHC.Stack
     ( HasCallStack )
+import GHC.TypeLits
+    ( KnownNat, Nat, natVal )
 
 import qualified Data.List as L
 import qualified Data.Map.Strict as Map
@@ -718,3 +726,113 @@ instance
                 addresses (liftPaymentAddress @n @k) (externalPool s)
         in
             nonChangeAddresses <> changeAddresses
+
+--------------------------------------------------------------------------------
+--
+-- SeqAnyState
+--
+-- For benchmarking and testing arbitrary large sequential wallets.
+
+-- | An "unsound" alternative that can be used for benchmarking and stress
+-- testing. It re-uses the same underlying structure as the `SeqState` but
+-- it discovers addresses based on an arbitrary ratio instead of respecting
+-- BIP-44 discovery.
+--
+-- The proportion is stored as a type-level parameter so that we don't have to
+-- alter the database schema to store it. It simply exists and depends on the
+-- caller creating the wallet to define it.
+newtype SeqAnyState (network :: NetworkDiscriminant) key (p :: Nat) = SeqAnyState
+    { innerState :: SeqState network key
+    } deriving (Generic)
+
+deriving instance
+    ( Show (k 'AccountK XPub)
+    , Show (k 'AddressK XPub)
+    , Show (KeyFingerprint "payment" k)
+    ) => Show (SeqAnyState n k p)
+
+instance
+    ( NFData (k 'AccountK XPub)
+    , NFData (k 'AddressK XPub)
+    , NFData (KeyFingerprint "payment" k)
+    )
+    => NFData (SeqAnyState n k p)
+
+-- | Initialize the HD random address discovery state from a root key and RNG
+-- seed.
+--
+-- The type parameter is expected to be a ratio of addresses we ought to simply
+-- recognize as ours. It is expressed in tenths of percent, so "1" means 0.1%,
+-- "10" means 1% and 1000 means 100%.
+mkSeqAnyState
+    :: forall (p :: Nat) n k.
+        ( SoftDerivation k
+        , MkKeyFingerprint k (Proxy n, k 'AddressK XPub)
+        , MkKeyFingerprint k Address
+        , WalletKey k
+        , Bounded (Index (AddressIndexDerivationType k) 'AddressK)
+        )
+    => (k 'RootK XPrv, Passphrase "encryption")
+    -> AddressPoolGap
+    -> SeqAnyState n k p
+mkSeqAnyState credentials poolGap = SeqAnyState
+    { innerState = mkSeqStateFromRootXPrv credentials poolGap
+    }
+
+instance
+    ( SoftDerivation k
+    , MkKeyFingerprint k (Proxy n, k 'AddressK XPub)
+    , KnownNat p
+    ) => IsOurs (SeqAnyState n k p) Address
+  where
+    isOurs (Address bytes) st@(SeqAnyState inner)
+        | crc32 bytes < p =
+            let
+                edge = Map.size (indexedKeys $ externalPool inner)
+                ix = toEnum (edge - fromEnum (gap $ externalPool inner))
+                pool' = extendAddressPool @n ix (externalPool inner)
+            in
+                (True, SeqAnyState (inner { externalPool = pool' }))
+        | otherwise =
+            (False, st)
+      where
+        p = floor (double sup * double (natVal (Proxy @p)) / 1000)
+          where
+            sup = maxBound :: Word32
+
+        double :: Integral a => a -> Double
+        double = fromIntegral
+
+instance IsOurs (SeqAnyState n k p) ChimericAccount
+  where
+    isOurs _account state = (False, state)
+
+instance
+    ( SoftDerivation k
+    , MkKeyFingerprint k (Proxy n, k 'AddressK XPub)
+    , AddressIndexDerivationType k ~ 'Soft
+    , KnownNat p
+    ) => IsOwned (SeqAnyState n k p) k
+  where
+    isOwned _ _ _ = Nothing
+
+instance
+    ( SoftDerivation k
+    ) => GenChange (SeqAnyState n k p)
+  where
+    type ArgGenChange (SeqAnyState n k p) = ArgGenChange (SeqState n k)
+    genChange a (SeqAnyState s) = SeqAnyState <$> genChange a s
+
+instance
+    ( MkKeyFingerprint k (Proxy n, k 'AddressK XPub)
+    , MkKeyFingerprint k Address
+    , SoftDerivation k
+    ) => CompareDiscovery (SeqAnyState n k p)
+  where
+    compareDiscovery (SeqAnyState s) = compareDiscovery s
+
+instance
+    ( PaymentAddress n k
+    ) => KnownAddresses (SeqAnyState n k p)
+  where
+    knownAddresses (SeqAnyState s) = knownAddresses s

lib/core/src/Cardano/Wallet/Primitive/Types.hs

@@ -1253,6 +1253,8 @@ data UTxOStatistics = UTxOStatistics
     , boundType :: BoundType
     } deriving (Show, Generic, Ord)
 
+instance NFData UTxOStatistics
+
 -- Example output:
 --
 -- @
@@ -1308,12 +1310,16 @@ data HistogramBar = HistogramBar
     , bucketCount      :: !Word64
     } deriving (Show, Eq, Ord, Generic)
 
+instance NFData HistogramBar
+
 instance Buildable HistogramBar where
     build (HistogramBar k v) = tupleF (k, v)
 
 --  Buckets boundaries can be constructed in different ways
 data BoundType = Log10 deriving (Eq, Show, Ord, Generic)
 
+instance NFData BoundType
+
 -- | Smart-constructor to create bounds using a log-10 scale
 log10 :: BoundType
 log10 = Log10