From 0f554686adb23949ff333368883b61343e24ae7a Mon Sep 17 00:00:00 2001 From: Rodney Lorrimar Date: Mon, 8 Apr 2019 18:17:54 +1000 Subject: [PATCH] Add new address discovery schemes for testing and benchmarking --- cardano-wallet.cabal | 1 + src/Cardano/Wallet.hs | 46 ++++++---- .../Primitive/AddressDiscovery/Fixed.hs | 92 +++++++++++++++++++ test/bench/Main.hs | 31 ++++--- 4 files changed, 140 insertions(+), 30 deletions(-) create mode 100644 src/Cardano/Wallet/Primitive/AddressDiscovery/Fixed.hs diff --git a/cardano-wallet.cabal b/cardano-wallet.cabal index 64082c1c40a..9b78795537d 100644 --- a/cardano-wallet.cabal +++ b/cardano-wallet.cabal @@ -78,6 +78,7 @@ library Cardano.Wallet.Network.HttpBridge.Api Cardano.Wallet.Primitive.AddressDerivation Cardano.Wallet.Primitive.AddressDiscovery + Cardano.Wallet.Primitive.AddressDiscovery.Fixed Cardano.Wallet.Primitive.Mnemonic Cardano.Wallet.Primitive.Model Cardano.Wallet.Primitive.Types diff --git a/src/Cardano/Wallet.hs b/src/Cardano/Wallet.hs index 20567a3a5d0..8d02f4b2970 100644 --- a/src/Cardano/Wallet.hs +++ b/src/Cardano/Wallet.hs @@ -21,6 +21,7 @@ module Cardano.Wallet , NewWallet(..) , ReadWalletError(..) , CreateWalletError(..) + , InitState(..) -- * Construction , mkWalletLayer @@ -48,7 +49,9 @@ import Cardano.Wallet.Primitive.AddressDiscovery import Cardano.Wallet.Primitive.Model ( Wallet, applyBlock, initWallet ) import Cardano.Wallet.Primitive.Types - ( Block (..), SlotId, WalletId (..), WalletMetadata (..), WalletName (..) ) + ( Block (..), SlotId, WalletId (..), WalletMetadata (..), WalletName (..), IsOurs (..) ) +import Control.DeepSeq + ( NFData ) import Control.Exception ( Exception ) import Control.Monad @@ -71,7 +74,7 @@ import GHC.Generics data WalletLayer s = WalletLayer { createWallet - :: NewWallet + :: NewWallet s -> ExceptT CreateWalletError IO WalletId -- ^ Initialise and store a new wallet, returning its ID. , readWallet @@ -92,7 +95,7 @@ data WalletLayer s = WalletLayer -- benchmarking. } -data NewWallet = NewWallet +data NewWallet s = NewWallet { seed :: !(Passphrase "seed") , secondFactor @@ -119,27 +122,36 @@ newtype CreateWalletError Construction -------------------------------------------------------------------------------} --- | Create a new instance of the wallet layer. -mkWalletLayer - :: (Exception e0) - => DBLayer IO SeqState - -> NetworkLayer IO e0 e1 - -> WalletLayer SeqState -mkWalletLayer db network = WalletLayer - { createWallet = \w -> do - let rootXPrv = +class (IsOurs s, NFData s, Show s) => InitState s where + initState :: NewWallet s -> (WalletId, s) + +instance InitState SeqState where + initState w = (wid, seqState) + where + rootXPrv = generateKeyFromSeed (seed w, secondFactor w) (passphrase w) - let accXPrv = + accXPrv = deriveAccountPrivateKey mempty rootXPrv minBound - let extPool = + extPool = mkAddressPool (publicKey accXPrv) (gap w) ExternalChain [] - let intPool = + intPool = mkAddressPool (publicKey accXPrv) minBound InternalChain [] - let wallet = initWallet $ SeqState + seqState = SeqState { externalPool = extPool , internalPool = intPool } - let wid = WalletId (digest $ publicKey rootXPrv) + wid = WalletId (digest $ publicKey rootXPrv) + +-- | Create a new instance of the wallet layer. +mkWalletLayer + :: (InitState s, Exception e0) + => DBLayer IO s + -> NetworkLayer IO e0 e1 + -> WalletLayer s +mkWalletLayer db network = WalletLayer + { createWallet = \w -> do + let (wid, s) = initState w + wallet = initWallet s liftIO (readCheckpoint db (PrimaryKey wid)) >>= \case Nothing -> do liftIO $ putCheckpoint db (PrimaryKey wid) wallet diff --git a/src/Cardano/Wallet/Primitive/AddressDiscovery/Fixed.hs b/src/Cardano/Wallet/Primitive/AddressDiscovery/Fixed.hs new file mode 100644 index 00000000000..d715ace6f49 --- /dev/null +++ b/src/Cardano/Wallet/Primitive/AddressDiscovery/Fixed.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeApplications #-} + +-- | +-- Copyright: © 2018-2019 IOHK +-- License: MIT +-- +-- fixme: blurb + +module Cardano.Wallet.Primitive.AddressDiscovery.Fixed + ( -- * Fixed address list + FixedAddressState (..) + + -- ** State + , AnyAddressState (..) + ) where + +import Prelude + +import Cardano.Wallet.Primitive.Types + ( Address(..), IsOurs (..), invariant, WalletId(..) ) +import Cardano.Wallet ( InitState(..)) +import Data.Set + ( Set ) +import Data.Map.Strict + ( Map ) +import Data.Maybe + ( isJust ) +import Data.Text.Class + ( FromText (..), TextDecodingError (..), ToText (..) ) +import GHC.Generics + ( Generic ) +import Control.DeepSeq + ( NFData ) +import Text.Read + ( readMaybe ) +import Data.Word (Word32) +import Data.Digest.CRC32 (crc32) +import Crypto.Hash + ( Digest, HashAlgorithm, hash ) + +import qualified Data.ByteString.Char8 as B8 +import qualified Data.Set as Set +import qualified Data.Text as T + +{------------------------------------------------------------------------------- + Fixed Address Derivation + + The given set of addresses are recognized as "ours". + +-------------------------------------------------------------------------------} + +data FixedAddressState = FixedAddressState + { knownAddresses :: !(Set Address) + } + deriving stock (Generic, Show) + +instance NFData FixedAddressState + +instance IsOurs FixedAddressState where + isOurs addr s = (Set.member addr (knownAddresses s), s) + + +{------------------------------------------------------------------------------- + Any Address Derivation + + An arbitrary proportion of addreses are recognized as "ours". This is done + by looking at a checksum of the address. + +-------------------------------------------------------------------------------} + +data AnyAddressState = AnyAddressState + { oursProportion :: !Double + } + deriving stock (Generic, Show) + +instance NFData AnyAddressState + +instance IsOurs AnyAddressState where + isOurs (Address addr) s@(AnyAddressState p) = (crc32 addr < p', s) + where + p' = floor (fromIntegral (maxBound :: Word32) * p) + +instance InitState AnyAddressState where + initState s = (walletId s, AnyAddressState 0.5) + +walletId :: Show a => a -> WalletId +walletId = WalletId . hash . B8.pack . show diff --git a/test/bench/Main.hs b/test/bench/Main.hs index 66fafee205e..ee676ec4f4e 100644 --- a/test/bench/Main.hs +++ b/test/bench/Main.hs @@ -37,7 +37,7 @@ import System.Exit ( die ) import Cardano.Wallet - ( NewWallet (..), WalletLayer (..), mkWalletLayer ) + ( NewWallet (..), WalletLayer (..), InitState(..), mkWalletLayer ) import Cardano.Wallet.Network ( NetworkLayer, networkTip ) import Cardano.Wallet.Network.HttpBridge @@ -45,9 +45,11 @@ import Cardano.Wallet.Network.HttpBridge import Cardano.Wallet.Primitive.AddressDerivation ( Passphrase (..) ) import Cardano.Wallet.Primitive.AddressDiscovery - ( mkAddressPoolGap ) + ( SeqState(..), mkAddressPoolGap ) +import Cardano.Wallet.Primitive.AddressDiscovery.Fixed import Cardano.Wallet.Primitive.Types - ( SlotId (..), WalletName (..) ) + ( SlotId (..), WalletName (..), WalletId ) +import Cardano.Wallet.Primitive.Model (availableBalance) import qualified Cardano.Wallet.DB.MVar as MVar import qualified Data.Text as T @@ -57,8 +59,8 @@ main = do installSignalHandlers mapM_ prepareNode ["testnet", "mainnet"] runBenchmarks - [ bench "restore - testnet - walletRnd" $ test1 "testnet" walletRnd - , bench "restore - mainnet - walletRnd" $ test1 "mainnet" walletRnd + [ bench "restore - testnet - walletRnd" $ test1 "testnet" walletAny + , bench "restore - mainnet - walletRnd" $ test1 "mainnet" walletAny , bench "restore - testnet - walletSeq" $ test1 "testnet" walletSeq , bench "restore - mainnet - walletSeq" $ test1 "mainnet" walletSeq ] @@ -85,7 +87,7 @@ printResult :: Text -> Double -> IO () printResult benchName dur = say . fmt $ " "+|benchName|+": "+|secs dur|+"" -test1 :: Text -> NewWallet -> IO () +test1 :: InitState s => Text -> NewWallet s -> IO () test1 netName nw = withHttpBridge netName $ \port -> do db <- MVar.newDBLayer network <- newNetworkLayer netName port @@ -95,11 +97,14 @@ test1 netName nw = withHttpBridge netName $ \port -> do let testWalletLayer = mkWalletLayer db network res <- runExceptT $ createWallet testWalletLayer nw case res of - Right wal -> processWallet testWalletLayer logChunk wal + Right wal -> processWallet testWalletLayer (logChunk testWalletLayer wal) wal Left err -> die $ show err -logChunk :: SlotId -> IO () -logChunk slot = say . fmt $ "Processing "+||slot||+"" +logChunk :: WalletLayer s -> WalletId -> SlotId -> IO () +logChunk wl wid slot = do + say . fmt $ "Processing "+||slot||+"" + Right (wal, _) <- runExceptT $ readWallet wl wid + say . fmt $ "Available balance: "+||availableBalance wal||+"" withHttpBridge :: Text -> (Int -> IO a) -> IO a withHttpBridge netName action = bracket start stop (const (action port)) @@ -122,18 +127,18 @@ withHttpBridge netName action = bracket start stop (const (action port)) threadDelay 1000000 -- wait for socket to be closed -baseWallet :: NewWallet +baseWallet :: NewWallet s baseWallet = NewWallet (Passphrase "") (Passphrase "") (WalletName "") (Passphrase "") gap20 where Right gap20 = mkAddressPoolGap 20 -walletRnd :: NewWallet -walletRnd = baseWallet +walletAny :: NewWallet AnyAddressState +walletAny = baseWallet { seed = Passphrase "skull skin weird piece oak absorb apart above female dial drink traffic" , name = WalletName "Benchmark Daedalus Wallet" } -walletSeq :: NewWallet +walletSeq :: NewWallet SeqState walletSeq = baseWallet { seed = Passphrase "involve key curtain arrest fortune custom lens marine before material wheel glide cause weapon wrap" , name = WalletName "Benchmark Yoroi Wallet"