diff --git a/cardano-wallet.cabal b/cardano-wallet.cabal index 742b25c2afa..897b64a6379 100644 --- a/cardano-wallet.cabal +++ b/cardano-wallet.cabal @@ -307,9 +307,13 @@ benchmark restore base , ansi-terminal , async + , bytestring , cardano-wallet + , containers , criterion-measurement + , cryptonite , deepseq + , digest , docopt , fmt , generic-lens @@ -328,6 +332,7 @@ benchmark restore other-modules: Cardano.CLI Cardano.Launcher + Cardano.Wallet.Primitive.AddressDiscovery.Fixed if os(windows) build-depends: Win32 other-modules: Cardano.Launcher.Windows diff --git a/src/Cardano/Wallet.hs b/src/Cardano/Wallet.hs index 0549cae7299..fe6bdf8aed9 100644 --- a/src/Cardano/Wallet.hs +++ b/src/Cardano/Wallet.hs @@ -21,6 +21,7 @@ module Cardano.Wallet , NewWallet(..) , ReadWalletError(..) , CreateWalletError(..) + , InitState(..) -- * Construction , mkWalletLayer @@ -44,11 +45,19 @@ import Cardano.Wallet.Primitive.AddressDerivation , publicKey ) import Cardano.Wallet.Primitive.AddressDiscovery - ( AddressPoolGap, SeqState (..), mkAddressPool ) + ( AddressPoolGap, SeqState (..), SeqStateConfig (..), mkAddressPool ) import Cardano.Wallet.Primitive.Model ( Wallet, applyBlocks, initWallet ) import Cardano.Wallet.Primitive.Types - ( Block (..), SlotId, WalletId (..), WalletMetadata (..), WalletName (..) ) + ( Block (..) + , IsOurs (..) + , SlotId + , WalletId (..) + , WalletMetadata (..) + , WalletName (..) + ) +import Control.DeepSeq + ( NFData ) import Control.Exception ( Exception ) import Control.Monad @@ -69,7 +78,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 @@ -90,7 +99,7 @@ data WalletLayer s = WalletLayer -- benchmarking. } -data NewWallet = NewWallet +data NewWallet s = NewWallet { seed :: !(Passphrase "seed") , secondFactor @@ -99,9 +108,9 @@ data NewWallet = NewWallet :: !WalletName , passphrase :: !(Passphrase "encryption") - , gap - :: !AddressPoolGap - } deriving (Show, Generic) + , addressDiscoveryConfig + :: AddressDiscoveryConfig s + } -- | Errors occuring when fetching a wallet newtype ReadWalletError @@ -117,27 +126,37 @@ 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 = - mkAddressPool (publicKey accXPrv) (gap w) ExternalChain [] - let intPool = + ad = addressDiscoveryConfig w + extPool = + mkAddressPool (publicKey accXPrv) (seqStateGap ad) ExternalChain [] + 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/Api/Server.hs b/src/Cardano/Wallet/Api/Server.hs index da6022cbf36..bf116b9afe9 100644 --- a/src/Cardano/Wallet/Api/Server.hs +++ b/src/Cardano/Wallet/Api/Server.hs @@ -34,7 +34,7 @@ import Cardano.Wallet.Api.Types , getApiMnemonicT ) import Cardano.Wallet.Primitive.AddressDiscovery - ( SeqState (..), defaultAddressPoolGap ) + ( SeqState (..), SeqStateConfig (..), defaultAddressPoolGap ) import Cardano.Wallet.Primitive.Model ( availableBalance, getState, totalBalance ) import Cardano.Wallet.Primitive.Types @@ -127,8 +127,10 @@ postWallet w req = do getApiT (req ^. #name) , passphrase = getApiT (req ^. #passphrase) - , gap = - maybe defaultAddressPoolGap getApiT (req ^. #addressPoolGap) + , addressDiscoveryConfig = SeqStateConfig + { seqStateGap = + maybe defaultAddressPoolGap getApiT (req ^. #addressPoolGap) + } } getWallet w (ApiT wid) diff --git a/src/Cardano/Wallet/Primitive/AddressDiscovery.hs b/src/Cardano/Wallet/Primitive/AddressDiscovery.hs index 94fe72683d0..35603848b80 100644 --- a/src/Cardano/Wallet/Primitive/AddressDiscovery.hs +++ b/src/Cardano/Wallet/Primitive/AddressDiscovery.hs @@ -4,6 +4,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} -- | -- Copyright: © 2018-2019 IOHK @@ -35,6 +36,7 @@ module Cardano.Wallet.Primitive.AddressDiscovery -- ** State , SeqState (..) + , SeqStateConfig (..) ) where import Prelude @@ -255,6 +257,10 @@ data SeqState = SeqState instance NFData SeqState +data SeqStateConfig = SeqStateConfig + { seqStateGap :: !AddressPoolGap + } deriving stock (Generic, Show) + -- NOTE -- We have to scan both the internal and external chain. Note that, the -- account discovery algorithm is only specified for the external chain so @@ -265,6 +271,8 @@ instance NFData SeqState -- that they are just created in sequence by the wallet software. Hence an -- address pool with a gap of 1 should be sufficient for the internal chain. instance IsOurs SeqState where + type AddressDiscoveryConfig SeqState = SeqStateConfig + isOurs addr (SeqState !s1 !s2) = let (res1, !s1') = lookupAddress addr s1 diff --git a/src/Cardano/Wallet/Primitive/Types.hs b/src/Cardano/Wallet/Primitive/Types.hs index 113e553dcb4..b987dfd4be0 100644 --- a/src/Cardano/Wallet/Primitive/Types.hs +++ b/src/Cardano/Wallet/Primitive/Types.hs @@ -391,6 +391,7 @@ newtype SignedTx = SignedTx { signedTx :: ByteString } -- same time, and this little abstraction can buy us this without introducing -- too much overhead. class IsOurs s where + type AddressDiscoveryConfig s isOurs :: Address -> s -> (Bool, s) newtype Address = Address diff --git a/test/bench/Cardano/Wallet/Primitive/AddressDiscovery/Fixed.hs b/test/bench/Cardano/Wallet/Primitive/AddressDiscovery/Fixed.hs new file mode 100644 index 00000000000..ef4723e8fba --- /dev/null +++ b/test/bench/Cardano/Wallet/Primitive/AddressDiscovery/Fixed.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Copyright: © 2018-2019 IOHK +-- License: MIT +-- +-- Custom address discovery schemes used for testing and benchmarking. +-- + +module Cardano.Wallet.Primitive.AddressDiscovery.Fixed + ( -- * Fixed address list + FixedAddressState (..) + + -- ** State + , AnyAddressState (..) + ) where + +import Prelude + +import Cardano.Wallet + ( InitState (..), NewWallet (..) ) +import Cardano.Wallet.Primitive.Types + ( Address (..), IsOurs (..), WalletId (..) ) +import Control.DeepSeq + ( NFData ) +import Crypto.Hash + ( hash ) +import Data.Digest.CRC32 + ( crc32 ) +import Data.Set + ( Set ) +import Data.Word + ( Word32 ) +import GHC.Generics + ( Generic ) + +import qualified Data.ByteString.Char8 as B8 +import qualified Data.Set as Set + +---------------------------------------------------------------------------- + +-- | 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 + type AddressDiscoveryConfig FixedAddressState = FixedAddressState + isOurs addr s = (Set.member addr (knownAddresses s), s) + +instance InitState FixedAddressState where + initState w = (walletId cfg, cfg) + where cfg = addressDiscoveryConfig w + +---------------------------------------------------------------------------- + +-- | Any Address Derivation +-- +-- An arbitrary fraction 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 + type AddressDiscoveryConfig AnyAddressState = AnyAddressState + + isOurs (Address addr) s@(AnyAddressState p) = (crc32 addr < p', s) + where + p' = floor (fromIntegral (maxBound :: Word32) * p) + +instance InitState AnyAddressState where + initState w = (walletId cfg, cfg) + where cfg = addressDiscoveryConfig w + +walletId :: Show a => a -> WalletId +walletId = WalletId . hash . B8.pack . show diff --git a/test/bench/Main.hs b/test/bench/Main.hs index 83defb1526f..cced8eda14e 100644 --- a/test/bench/Main.hs +++ b/test/bench/Main.hs @@ -5,22 +5,6 @@ module Main where import Prelude -import Cardano.CLI - ( Network (..) ) -import Cardano.Launcher - ( Command (Command), StdStream (..), installSignalHandlers, launch ) -import Cardano.Wallet - ( NewWallet (..), WalletLayer (..), mkWalletLayer, unsafeRunExceptT ) -import Cardano.Wallet.Network - ( NetworkLayer (..), networkTip ) -import Cardano.Wallet.Network.HttpBridge - ( newNetworkLayer ) -import Cardano.Wallet.Primitive.AddressDerivation - ( Passphrase (..) ) -import Cardano.Wallet.Primitive.AddressDiscovery - ( mkAddressPoolGap ) -import Cardano.Wallet.Primitive.Types - ( SlotId (..), WalletName (..) ) import Control.Arrow ( left ) import Control.Concurrent @@ -54,7 +38,35 @@ import Say import System.Environment ( getArgs ) +import Cardano.CLI + ( Network (..) ) +import Cardano.Launcher + ( Command (Command), StdStream (..), installSignalHandlers, launch ) +import Cardano.Wallet + ( InitState (..) + , NewWallet (..) + , WalletLayer (..) + , mkWalletLayer + , unsafeRunExceptT + ) +import Cardano.Wallet.DB + ( DBLayer (..), PrimaryKey (..) ) +import Cardano.Wallet.Network + ( NetworkLayer (..), networkTip ) +import Cardano.Wallet.Network.HttpBridge + ( newNetworkLayer ) +import Cardano.Wallet.Primitive.AddressDerivation + ( Passphrase (..) ) +import Cardano.Wallet.Primitive.AddressDiscovery + ( SeqState (..), SeqStateConfig (..), mkAddressPoolGap ) +import Cardano.Wallet.Primitive.AddressDiscovery.Fixed +import Cardano.Wallet.Primitive.Model + ( availableBalance ) +import Cardano.Wallet.Primitive.Types + ( AddressDiscoveryConfig (..), SlotId (..), WalletId, WalletName (..) ) + import qualified Cardano.Wallet.DB.MVar as MVar +import qualified Data.Map as Map import qualified Data.Text as T -- | Run all available benchmarks. Can accept one argument that is a target @@ -69,6 +81,8 @@ main = do runBenchmarks [ bench ("restore " <> toText network <> " seq") (bench_restoration network walletSeq) + , bench ("restore " <> toText network <> " 50% address ownership") + (bench_restoration network (walletAny 0.5)) ] -- | Very simplistic benchmark argument parser. If anything more is ever needed, @@ -110,7 +124,7 @@ printResult benchName dur = say . fmt $ " "+|benchName|+": "+|secs dur|+"" -------------------------------------------------------------------------------} {-# ANN bench_restoration ("HLint: ignore Use camelCase" :: String) #-} -bench_restoration :: Network -> NewWallet -> IO () +bench_restoration :: InitState s => Network -> NewWallet s -> IO () bench_restoration network nw = withHttpBridge network $ \port -> do dbLayer <- MVar.newDBLayer networkLayer <- newNetworkLayer networkName port @@ -118,12 +132,17 @@ bench_restoration network nw = withHttpBridge network $ \port -> do say . fmt $ "Note: the "+|networkName|+" tip is at "+||(bh ^. #slotId)||+"" let walletLayer = mkWalletLayer dbLayer networkLayer wallet <- unsafeRunExceptT $ createWallet walletLayer nw - processWallet walletLayer logChunk wallet + processWallet walletLayer (logChunk walletLayer dbLayer wallet) wallet where networkName = toText network -logChunk :: SlotId -> IO () -logChunk slot = say . fmt $ "Processing "+||slot||+"" +logChunk :: WalletLayer s -> DBLayer IO s -> WalletId -> SlotId -> IO () +logChunk wl db wid slot = do + say . fmt $ "Processing "+|slot|+"" + (wal, _) <- unsafeRunExceptT $ readWallet wl wid + say . fmt $ " Available balance: "+||availableBalance wal||+"" + txs <- readTxHistory db (PrimaryKey wid) + say . fmt $ " Num transactions: "+|Map.size txs|+"" withHttpBridge :: Network -> (Int -> IO a) -> IO a withHttpBridge network action = bracket start stop (const (action port)) @@ -146,16 +165,27 @@ withHttpBridge network action = bracket start stop (const (action port)) threadDelay 1000000 -- wait for socket to be closed -baseWallet :: NewWallet -baseWallet = NewWallet (Passphrase "") (Passphrase "") - (WalletName "") (Passphrase "") gap20 - where Right gap20 = mkAddressPoolGap 20 +baseWallet :: AddressDiscoveryConfig s -> NewWallet s +baseWallet = NewWallet + (Passphrase "") (Passphrase "") + (WalletName "") (Passphrase "") -walletSeq :: NewWallet -walletSeq = baseWallet +-- | Test wallet where the given fraction of addresses are discovered to be +-- "owned" by the wallet. +walletAny :: Double -> NewWallet AnyAddressState +walletAny p = (baseWallet (AnyAddressState p)) + { seed = Passphrase "" + , name = WalletName "Benchmark \"any address\" Wallet" + } + +-- | An empty wallet for benchmarking. There should be few or no transactions +-- associated with this wallet. +walletSeq :: NewWallet SeqState +walletSeq = (baseWallet (SeqStateConfig gap20)) { seed = Passphrase "involve key curtain arrest fortune custom lens marine before material wheel glide cause weapon wrap" , name = WalletName "Benchmark Sequential Wallet" } + where Right gap20 = mkAddressPoolGap 20 prepareNode :: Network -> IO () prepareNode net = do diff --git a/test/integration/Cardano/WalletSpec.hs b/test/integration/Cardano/WalletSpec.hs index 240750c6f59..a69f07d2dd8 100644 --- a/test/integration/Cardano/WalletSpec.hs +++ b/test/integration/Cardano/WalletSpec.hs @@ -14,6 +14,8 @@ import Cardano.Wallet ( NewWallet (..), WalletLayer (..), mkWalletLayer, unsafeRunExceptT ) import Cardano.Wallet.Primitive.AddressDerivation ( Passphrase (..) ) +import Cardano.Wallet.Primitive.AddressDiscovery + ( SeqState, SeqStateConfig (..) ) import Cardano.Wallet.Primitive.Mnemonic ( EntropySize, entropyToBytes, genEntropy ) import Cardano.Wallet.Primitive.Model @@ -35,13 +37,15 @@ spec = do before startBridge $ after closeBridge $ do it "A newly created wallet can sync with the chain" $ \(_, wallet) -> do bytes <- entropyToBytes <$> genEntropy @(EntropySize 15) - wid <- unsafeRunExceptT $ createWallet wallet NewWallet - { seed = Passphrase bytes - , secondFactor = mempty - , name = WalletName "My Wallet" - , passphrase = mempty - , gap = minBound - } + let wal = NewWallet + { seed = Passphrase bytes + , secondFactor = mempty + , name = WalletName "My Wallet" + , passphrase = mempty + , addressDiscoveryConfig = + SeqStateConfig { seqStateGap = minBound } + } :: NewWallet SeqState + wid <- unsafeRunExceptT $ createWallet wallet wal handle <- async (watchWallet wallet wid) threadDelay 5000000 cancel handle diff --git a/test/unit/Cardano/Wallet/Primitive/ModelSpec.hs b/test/unit/Cardano/Wallet/Primitive/ModelSpec.hs index 23c8dcb101d..d5deb6d075f 100644 --- a/test/unit/Cardano/Wallet/Primitive/ModelSpec.hs +++ b/test/unit/Cardano/Wallet/Primitive/ModelSpec.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Cardano.Wallet.Primitive.ModelSpec @@ -255,6 +256,7 @@ instance Semigroup WalletState where (\_ -> ours == ours') instance IsOurs WalletState where + type AddressDiscoveryConfig WalletState = () isOurs addr s@(WalletState ours discovered) = if (ShowFmt addr) `elem` ours then (True, WalletState ours (Set.insert (ShowFmt addr) discovered)) diff --git a/test/unit/Cardano/WalletSpec.hs b/test/unit/Cardano/WalletSpec.hs index 69b6c9c2e17..e1a7ff6e61a 100644 --- a/test/unit/Cardano/WalletSpec.hs +++ b/test/unit/Cardano/WalletSpec.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -24,7 +25,7 @@ import Cardano.Wallet.Network.HttpBridge import Cardano.Wallet.Primitive.AddressDerivation ( Passphrase (..) ) import Cardano.Wallet.Primitive.AddressDiscovery - ( AddressPoolGap, SeqState ) + ( AddressPoolGap, SeqState, SeqStateConfig (..) ) import Cardano.Wallet.Primitive.Mnemonic ( Entropy , EntropySize @@ -93,7 +94,7 @@ spec = do -------------------------------------------------------------------------------} walletCreationProp - :: NewWallet + :: NewWallet SeqState -> Property walletCreationProp newWallet = monadicIO $ liftIO $ do (WalletLayerFixture db _wl walletIds) <- setupFixture newWallet @@ -101,7 +102,7 @@ walletCreationProp newWallet = monadicIO $ liftIO $ do resFromDb `shouldSatisfy` isJust walletDoubleCreationProp - :: NewWallet + :: NewWallet SeqState -> Property walletDoubleCreationProp newWallet = monadicIO $ liftIO $ do (WalletLayerFixture _db wl _walletIds) <- setupFixture newWallet @@ -109,7 +110,7 @@ walletDoubleCreationProp newWallet = monadicIO $ liftIO $ do secondTrial `shouldSatisfy` isLeft walletGetProp - :: NewWallet + :: NewWallet SeqState -> Property walletGetProp newWallet = monadicIO $ liftIO $ do (WalletLayerFixture _db wl walletIds) <- liftIO $ setupFixture newWallet @@ -117,7 +118,7 @@ walletGetProp newWallet = monadicIO $ liftIO $ do resFromGet `shouldSatisfy` isRight walletGetWrongIdProp - :: (NewWallet, WalletId) + :: (NewWallet SeqState, WalletId) -> Property walletGetWrongIdProp (newWallet, corruptedWalletId) = monadicIO $ liftIO $ do (WalletLayerFixture _db wl _walletIds) <- liftIO $ setupFixture newWallet @@ -125,7 +126,7 @@ walletGetWrongIdProp (newWallet, corruptedWalletId) = monadicIO $ liftIO $ do attempt `shouldSatisfy` isLeft walletIdDeterministic - :: NewWallet + :: NewWallet SeqState -> Property walletIdDeterministic newWallet = monadicIO $ liftIO $ do (WalletLayerFixture _ _ widsA) <- liftIO $ setupFixture newWallet @@ -133,7 +134,7 @@ walletIdDeterministic newWallet = monadicIO $ liftIO $ do widsA `shouldBe` widsB walletIdInjective - :: (NewWallet, NewWallet) + :: (NewWallet SeqState, NewWallet SeqState) -> Property walletIdInjective (walletA, walletB) = monadicIO $ liftIO $ do (WalletLayerFixture _ _ widsA) <- liftIO $ setupFixture walletA @@ -151,7 +152,7 @@ data WalletLayerFixture = WalletLayerFixture { } setupFixture - :: NewWallet + :: NewWallet SeqState -> IO WalletLayerFixture setupFixture newWallet = do db <- newDBLayer @@ -163,7 +164,9 @@ setupFixture newWallet = do Right walletId -> [walletId] pure $ WalletLayerFixture db wl wal -instance Arbitrary NewWallet where +deriving instance Show (NewWallet SeqState) + +instance Arbitrary (NewWallet SeqState) where -- No shrinking arbitrary = NewWallet <$> arbitrary @@ -172,6 +175,9 @@ instance Arbitrary NewWallet where <*> arbitrary <*> arbitrary +instance Arbitrary SeqStateConfig where + arbitrary = SeqStateConfig <$> arbitrary + instance ( ValidEntropySize n , ValidChecksumSize n csz