Add new address discovery schemes for testing and benchmarking

cardano-foundation · Apr 8, 2019 · 0f55468 · 0f55468
1 parent 237fb73
commit 0f55468
Show file tree

Hide file tree

Showing 4 changed files with 140 additions and 30 deletions.
diff --git 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
@@ -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
@@ -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
@@ -37,17 +37,19 @@ 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
     ( newNetworkLayer )
 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"