Add new address discovery schemes for testing and benchmarking

cardano-foundation · Apr 9, 2019 · ea4d55b · ea4d55b
1 parent 39fe3f5
commit ea4d55b
Show file tree

Hide file tree

Showing 10 changed files with 234 additions and 67 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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