Refactor and simplify SharedState n k

* Use the new address pool data structure from `Cardano.Wallet.Address.Pool`
* Remove `ParentContextShared` constructor from sequential state
* Merge `SharedStateFields` and `SharedStatePending` types into `SharedSate`.

lib/core/src/Cardano/Wallet.hs

@@ -286,20 +286,13 @@ import Cardano.Wallet.Primitive.AddressDiscovery
 import Cardano.Wallet.Primitive.AddressDiscovery.Random
     ( ErrImportAddress (..), RndStateLike )
 import Cardano.Wallet.Primitive.AddressDiscovery.Sequential
-    ( ParentContext (..)
-    , SeqState
-    , defaultAddressPoolGap
-    , mkSeqStateFromRootXPrv
-    , purposeBIP44
-    )
+    ( SeqState, defaultAddressPoolGap, mkSeqStateFromRootXPrv, purposeBIP44 )
 import Cardano.Wallet.Primitive.AddressDiscovery.Shared
     ( CredentialType (..)
     , ErrAddCosigner (..)
     , ErrScriptTemplate (..)
     , SharedState (..)
-    , SharedStateFields (..)
     , addCosignerAccXPub
-    , isShared
     )
 import Cardano.Wallet.Primitive.CoinSelection
     ( Selection
@@ -744,7 +737,6 @@ createIcarusWallet
         , PaymentAddress n k
         , k ~ IcarusKey
         , s ~ SeqState n k
-        , Typeable n
         )
     => ctx
     -> WalletId
@@ -2907,11 +2899,11 @@ updateCosigner
     -> Cosigner
     -> CredentialType
     -> ExceptT ErrAddCosignerKey IO ()
-updateCosigner ctx wid accXPub cosigner cred = db & \DBLayer{..} -> do
+updateCosigner ctx wid cosignerXPub cosigner cred = db & \DBLayer{..} -> do
     mapExceptT atomically $ do
         cp <- withExceptT ErrAddCosignerKeyNoSuchWallet $ withNoSuchWallet wid $
               readCheckpoint wid
-        case addCosignerAccXPub accXPub cosigner cred (getState cp) of
+        case addCosignerAccXPub (cosigner, cosignerXPub) cred (getState cp) of
             Left err -> throwE (ErrAddCosignerKey err)
             Right st' -> withExceptT ErrAddCosignerKeyNoSuchWallet $
                 putCheckpoint wid (updateState st' cp)
@@ -2923,23 +2915,16 @@ updateCosigner ctx wid accXPub cosigner cred = db & \DBLayer{..} -> do
 -- base addresses (containing both payment and delegation credentials).
 -- So we normalize them all to be base addresses to make sure that we compare them correctly.
 normalizeSharedAddress
-    :: forall s k n.
-        ( MkKeyFingerprint k Address
-        , MkKeyFingerprint k (Proxy n, k 'AddressK XPub)
-        , s ~ SharedState n k
-        , k ~ SharedKey
-        , SoftDerivation k
-        , Typeable n
-        )
-    => s
+    :: forall n k. ( Shared.SupportsDiscovery n k, k ~ SharedKey )
+    => SharedState n k
     -> Address
     -> Maybe Address
-normalizeSharedAddress s@(SharedState _ state') addr = case state' of
-    PendingFields _ -> Nothing
-    ReadyFields pool -> do
-        let (ParentContextShared _ _ dTM) = Seq.context pool
+normalizeSharedAddress st addr = case Shared.ready st of
+    Shared.Pending -> Nothing
+    Shared.Active _ -> do
+        let dTM = Shared.delegationTemplate st
         fingerprint <- eitherToMaybe (paymentKeyFingerprint @k addr)
-        let (ixM, _) = isShared addr s
+        let (ixM, _) = Shared.isShared addr st
         case (dTM, ixM) of
             (Just dT, Just ix) ->
                 pure $ Shared.liftDelegationAddress @n ix dT fingerprint

lib/core/src/Cardano/Wallet/Address/Pool.hs

@@ -19,7 +19,7 @@ module Cardano.Wallet.Address.Pool
     , gap
     , lookup
     , size
-    , next
+    , successor
     , new
     , load
     , update
@@ -62,11 +62,18 @@ import qualified Data.Map.Strict as Map
 -- which are derived from a numeric index (type @ix@).
 data Pool addr ix = Pool
     { generator :: ix -> addr
-    -- ^ Each address is obtained from a numeric index.
-    -- The purpose of the 'Pool' data structure is to (partially)
-    -- cache this mapping,
-    -- because it is expensive to compute (hashing)
-    -- and its inverse is practically impossible to compute.
+    -- ^ Mapping from a numeric index to its corresponding address.
+    --
+    -- This mapping is supposed to be (practically) a one-way function:
+    -- Given an 'addr', it is impossible to compute the preimage
+    -- 'ix' in practice.
+    -- The purpose of the 'Pool' data structure is to help inverting
+    -- this function regardless. The idea is that addresses
+    -- with small indices @0,1,…@ are 'Used' before addresses with larger
+    -- indices; specifically, only less than 'gap' many addresses in sequence
+    -- may be 'Unused' before the next 'Used' address.
+    -- This usage scheme restricts the search space considerably
+    -- and allows us to practically invert the 'generator' function.
     , gap :: Int
     -- ^ The pool gap determines how 'Used' and 'Unused'
     -- have to be distributed.
@@ -93,18 +100,18 @@ prop_sequence Pool{addresses} =
 -- | Internal invariant:
 -- If we order the 'addresses' by their indices,
 -- then there are always /less than/ 'gap' many 'Unused'
--- addresses between two consecutive 'Used' addresses.
+-- addresses between two consecutive 'Used' addresses,
+-- or before the first 'Used' address.
 prop_gap :: Ord ix => Pool addr ix -> Bool
 prop_gap Pool{gap,addresses}
-    = all ((< gap) . length)
-    . filter isUnused
-    . dropFresh
-    $ List.group statuses
+    = all (< gap) . consecutiveUnused . List.group $ statuses
   where
-    isUnused (Unused:_) = True
-    isUnused _ = False
-    dropFresh = drop 1 -- drop items that are checked by 'prop_fresh'.
-    statuses = map snd $ List.sortOn (Down . fst) $ Map.elems addresses
+    consecutiveUnused ((Used:_):xs) = consecutiveUnused xs
+    consecutiveUnused (x@(Unused:_):(Used:_):xs) =
+        length x : consecutiveUnused xs
+    consecutiveUnused _ = []
+
+    statuses = map snd $ List.sortOn fst $ Map.elems addresses
 
 -- | Internal invariant:
 -- If we order the 'addresses' by their indices,
@@ -160,8 +167,8 @@ new generator gap
 load
     :: (Ord addr,  Ord ix, Enum ix)
     => Pool addr ix -> Map addr (ix,AddressState) -> Maybe (Pool addr ix)
-load addrs pool0 = if prop_consistent pool then Just pool else Nothing
-  where pool = loadUnsafe addrs pool0
+load pool0 addrs = if prop_consistent pool then Just pool else Nothing
+  where pool = loadUnsafe pool0 addrs
 
 -- | Replace the collection of addresses in a pool,
 -- but skips checking the invariants.
@@ -181,9 +188,21 @@ lookup addr Pool{addresses} = fst <$> Map.lookup addr addresses
 size :: Pool addr ix -> Int
 size = Map.size . addresses
 
--- | Given an index, retrieve the next index that is still in the pool.
-next :: Enum ix => Pool addr ix -> ix -> Maybe ix
-next Pool{addresses} ix = let jx = succ ix in
+-- | Given an index @ix@, return the enumerated successor @Just (succ ix)@
+-- as long as the address corresponding to this successor is still
+-- in the pool.
+--
+-- This function is useful for address discovery in a light client setting,
+-- where the discovery procedure is:
+-- Start with index @ix = 0@, query the corresponding address in an explorer,
+-- @update@ address pool and repeat with @successor ix@ until the latter
+-- returns 'Nothing'. According to the BIP-44 standard,
+-- the account may not contain any other addresses than the ones discovered.
+--
+-- This function is not useful for generating change addresses,
+-- as it does not take 'Used' or 'Unused' status into account.
+successor :: Enum ix => Pool addr ix -> ix -> Maybe ix
+successor Pool{addresses} ix = let jx = succ ix in
     if fromEnum jx >= Map.size addresses then Nothing else Just jx
 
 -- | Update an address to the 'Used' status
@@ -200,9 +219,14 @@ update addr pool@Pool{addresses} =
 -- | Create additional 'Unused' addresses from larger indices
 -- in order to satisfy 'prop_fresh' again.
 --
--- Precondition: Either @ix = fromEnum 0@,
--- or the index @jx@ which satisfies to @ix = succ jx@
--- is associated with a 'Used' address.
+-- Preconditions:
+-- 
+-- * The index @ix@ satisfies:
+--
+--     either @ix = fromEnum 0@
+--     or @ix = succ jx@ and the index @jx@ is a 'Used' address.
+--
+-- * All addresses with index @ix@ or larger are 'Unused'.
 ensureFresh :: (Ord addr, Enum ix) => ix -> Pool addr ix -> Pool addr ix
 ensureFresh ix pool@Pool{generator,gap,addresses}
     = pool { addresses = Map.union addresses nexts }

lib/core/src/Cardano/Wallet/Api/Server.hs

@@ -350,10 +350,8 @@ import Cardano.Wallet.Primitive.AddressDiscovery.Random
     ( RndState, mkRndState )
 import Cardano.Wallet.Primitive.AddressDiscovery.Sequential
     ( DerivationPrefix (..)
-    , ParentContext (..)
     , SeqState (..)
     , defaultAddressPoolGap
-    , gap
     , mkSeqStateFromAccountXPub
     , mkSeqStateFromRootXPrv
     , purposeCIP1852
@@ -363,8 +361,6 @@ import Cardano.Wallet.Primitive.AddressDiscovery.Shared
     , ErrAddCosigner (..)
     , ErrScriptTemplate (..)
     , SharedState (..)
-    , SharedStateFields (..)
-    , SharedStatePending (..)
     , mkSharedStateFromAccountXPub
     , mkSharedStateFromRootXPrv
     , validateScriptTemplates
@@ -602,6 +598,7 @@ import qualified Cardano.Wallet.DB as W
 import qualified Cardano.Wallet.Network as NW
 import qualified Cardano.Wallet.Primitive.AddressDerivation.Byron as Byron
 import qualified Cardano.Wallet.Primitive.AddressDerivation.Icarus as Icarus
+import qualified Cardano.Wallet.Primitive.AddressDiscovery.Shared as Shared
 import qualified Cardano.Wallet.Primitive.CoinSelection.Balance as Balance
 import qualified Cardano.Wallet.Primitive.CoinSelection.Collateral as Collateral
 import qualified Cardano.Wallet.Primitive.Types as W
@@ -818,7 +815,6 @@ postAccountWallet
         , WalletKey k
         , HasWorkerRegistry s k ctx
         , IsOurs s RewardAccount
-        , Typeable n
         , (k == SharedKey) ~ 'False
         )
     => ctx
@@ -1048,23 +1044,19 @@ mkSharedWallet
         ( ctx ~ ApiLayer s k
         , s ~ SharedState n k
         , HasWorkerRegistry s k ctx
-        , SoftDerivation k
-        , MkKeyFingerprint k (Proxy n, k 'AddressK XPub)
-        , MkKeyFingerprint k Address
-        , Typeable n
+        , Shared.SupportsDiscovery n k
         )
     => MkApiWallet ctx s ApiSharedWallet
-mkSharedWallet ctx wid cp meta pending progress = case getState cp of
-    SharedState (DerivationPrefix (_,_,accIx)) (PendingFields (SharedStatePending _ pTemplate dTemplateM g)) ->
-        pure $ ApiSharedWallet $ Left $ ApiPendingSharedWallet
+mkSharedWallet ctx wid cp meta pending progress = case Shared.ready st of
+    Shared.Pending -> pure $ ApiSharedWallet $ Left $ ApiPendingSharedWallet
         { id = ApiT wid
         , name = ApiT $ meta ^. #name
         , accountIndex = ApiT $ DerivationIndex $ getIndex accIx
-        , addressPoolGap = ApiT g
-        , paymentScriptTemplate = pTemplate
-        , delegationScriptTemplate = dTemplateM
+        , addressPoolGap = ApiT $ Shared.poolGap st
+        , paymentScriptTemplate = Shared.paymentTemplate st
+        , delegationScriptTemplate = Shared.delegationTemplate st
         }
-    SharedState (DerivationPrefix (_,_,accIx)) (ReadyFields pool) -> do
+    Shared.Active _ -> do
         reward <- withWorkerCtx @_ @s @k ctx wid liftE liftE $ \wrk ->
             -- never fails - returns zero if balance not found
             liftIO $ W.fetchRewardBalance @_ @s @k wrk wid
@@ -1078,16 +1070,15 @@ mkSharedWallet ctx wid cp meta pending progress = case getState cp of
             cp
         let available = availableBalance pending cp
         let total = totalBalance pending reward cp
-        let (ParentContextShared _ pTemplate dTemplateM) = pool ^. #context
         pure $ ApiSharedWallet $ Right $ ApiActiveSharedWallet
             { id = ApiT wid
             , name = ApiT $ meta ^. #name
             , accountIndex = ApiT $ DerivationIndex $ getIndex accIx
-            , addressPoolGap = ApiT $ gap pool
+            , addressPoolGap = ApiT $ Shared.poolGap st
             , passphrase = ApiWalletPassphraseInfo
                 <$> fmap (view #lastUpdatedAt) (meta ^. #passphraseInfo)
-            , paymentScriptTemplate = pTemplate
-            , delegationScriptTemplate = dTemplateM
+            , paymentScriptTemplate = Shared.paymentTemplate st
+            , delegationScriptTemplate = Shared.delegationTemplate st
             , delegation = apiDelegation
             , balance = ApiWalletBalance
                 { available = coinToQuantity (available ^. #coin)
@@ -1101,6 +1092,9 @@ mkSharedWallet ctx wid cp meta pending progress = case getState cp of
             , state = ApiT progress
             , tip = tip'
             }
+  where
+    st = getState cp
+    DerivationPrefix (_,_,accIx) = Shared.derivationPrefix st
 
 patchSharedWallet
     :: forall ctx s k n.
@@ -1275,7 +1269,6 @@ postIcarusWallet
         , k ~ IcarusKey
         , HasWorkerRegistry s k ctx
         , PaymentAddress n IcarusKey
-        , Typeable n
         )
     => ctx
     -> ByronWalletPostData '[12,15,18,21,24]
@@ -1296,7 +1289,6 @@ postTrezorWallet
         , k ~ IcarusKey
         , HasWorkerRegistry s k ctx
         , PaymentAddress n IcarusKey
-        , Typeable n
         )
     => ctx
     -> ByronWalletPostData '[12,15,18,21,24]
@@ -1317,7 +1309,6 @@ postLedgerWallet
         , k ~ IcarusKey
         , HasWorkerRegistry s k ctx
         , PaymentAddress n IcarusKey
-        , Typeable n
         )
     => ctx
     -> ByronWalletPostData '[12,15,18,21,24]