{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- |
-- Copyright: © 2018-2021 IOHK
-- License: Apache-2.0
--
-- An implementation of shared script state using
-- scheme specified in CIP-1854 Multi-signature Wallets.

module Cardano.Wallet.Primitive.AddressDiscovery.Shared
    (
      SupportsDiscovery

    -- ** State
    , SharedState (..)
    , Readiness (..)
    , SharedAddressPools (..)
    , SharedAddressPool (..)
    , newSharedAddressPool

    , ErrAddCosigner (..)
    , ErrScriptTemplate (..)
    , mkSharedStateFromAccountXPub
    , mkSharedStateFromRootXPrv
    , addCosignerAccXPub
    , isShared
    , retrieveAllCosigners
    , validateScriptTemplates
    , toSharedWalletId

    , CredentialType (..)
    , liftPaymentAddress
    , liftDelegationAddress
    ) where

import Prelude

import Cardano.Address.Script
    ( Cosigner (..)
    , ErrValidateScriptTemplate (..)
    , Script (..)
    , ScriptHash (..)
    , ScriptTemplate (..)
    , ValidationLevel (..)
    , foldScript
    , prettyErrValidateScriptTemplate
    , toScriptHash
    , validateScriptTemplate
    )
import Cardano.Address.Script.Parser
    ( scriptToText )
import Cardano.Address.Style.Shelley
    ( Credential (..), delegationAddress, paymentAddress )
import Cardano.Crypto.Wallet
    ( XPrv, XPub, unXPub )
import Cardano.Wallet.Primitive.AddressDerivation
    ( Depth (..)
    , DerivationIndex (..)
    , DerivationPrefix (..)
    , DerivationType (..)
    , HardDerivation (..)
    , Index (..)
    , KeyFingerprint (..)
    , MkKeyFingerprint (..)
    , NetworkDiscriminant (..)
    , PersistPublicKey (..)
    , Role (..)
    , SoftDerivation
    , WalletKey (..)
    , roleVal
    , utxoExternal
    , utxoInternal
    )
import Cardano.Wallet.Primitive.AddressDerivation.SharedKey
    ( SharedKey (..)
    , constructAddressFromIx
    , purposeCIP1854
    , replaceCosignersWithVerKeys
    , toNetworkTag
    )
import Cardano.Wallet.Primitive.AddressDiscovery
    ( CompareDiscovery (..)
    , GenChange (..)
    , GetAccount (..)
    , IsOurs (..)
    , KnownAddresses (..)
    , MaybeLight (..)
    , PendingIxs
    , coinTypeAda
    , emptyPendingIxs
    , nextChangeIndex
    , pendingIxsToList
    )
import Cardano.Wallet.Primitive.AddressDiscovery.Sequential
    ( AddressPoolGap (..), unsafePaymentKeyFingerprint )
import Cardano.Wallet.Primitive.Passphrase
    ( Passphrase )
import Cardano.Wallet.Primitive.Types.Address
    ( Address (..), AddressState (..) )
import Cardano.Wallet.Primitive.Types.RewardAccount
    ( RewardAccount )
import Control.Applicative
    ( (<|>) )
import Control.Arrow
    ( first )
import Control.DeepSeq
    ( NFData )
import Control.Monad
    ( unless )
import Crypto.Hash
    ( Blake2b_160, Digest, hash )
import Data.Either
    ( isRight )
import Data.Either.Combinators
    ( mapLeft )
import Data.Kind
    ( Type )
import Data.Proxy
    ( Proxy (..) )
import Data.Text
    ( Text )
import Data.Text.Class
    ( FromText (..), TextDecodingError (..), ToText (..) )
import Fmt
    ( Buildable (..), blockListF', indentF )
import GHC.Generics
    ( Generic )
import Type.Reflection
    ( Typeable )

import qualified Cardano.Address as CA
import qualified Cardano.Address.Style.Shelley as CA
import qualified Cardano.Wallet.Address.Pool as AddressPool
import qualified Data.Foldable as F
import qualified Data.List as L
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
import qualified Data.Text.Encoding as T


-- | Convenient alias for commonly used class contexts on keys.
type SupportsDiscovery (n :: NetworkDiscriminant) k =
    ( MkKeyFingerprint k (Proxy n, k 'AddressK XPub)
    , MkKeyFingerprint k Address
    , SoftDerivation k
    , Typeable n
    )

{-------------------------------------------------------------------------------
    Address Pool
-------------------------------------------------------------------------------}
data SharedAddressPools (key :: Depth -> Type -> Type) = SharedAddressPools
    { SharedAddressPools key -> SharedAddressPool 'UtxoExternal key
externalPool :: !(SharedAddressPool 'UtxoExternal key)
    , SharedAddressPools key -> SharedAddressPool 'UtxoInternal key
internalPool :: !(SharedAddressPool 'UtxoInternal key)
    , SharedAddressPools key -> PendingIxs 'ScriptK
pendingChangeIxs :: !(PendingIxs 'ScriptK)
    }
    deriving stock ((forall x.
 SharedAddressPools key -> Rep (SharedAddressPools key) x)
-> (forall x.
    Rep (SharedAddressPools key) x -> SharedAddressPools key)
-> Generic (SharedAddressPools key)
forall x. Rep (SharedAddressPools key) x -> SharedAddressPools key
forall x. SharedAddressPools key -> Rep (SharedAddressPools key) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (key :: Depth -> * -> *) x.
Rep (SharedAddressPools key) x -> SharedAddressPools key
forall (key :: Depth -> * -> *) x.
SharedAddressPools key -> Rep (SharedAddressPools key) x
$cto :: forall (key :: Depth -> * -> *) x.
Rep (SharedAddressPools key) x -> SharedAddressPools key
$cfrom :: forall (key :: Depth -> * -> *) x.
SharedAddressPools key -> Rep (SharedAddressPools key) x
Generic, Int -> SharedAddressPools key -> ShowS
[SharedAddressPools key] -> ShowS
SharedAddressPools key -> String
(Int -> SharedAddressPools key -> ShowS)
-> (SharedAddressPools key -> String)
-> ([SharedAddressPools key] -> ShowS)
-> Show (SharedAddressPools key)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (key :: Depth -> * -> *).
Int -> SharedAddressPools key -> ShowS
forall (key :: Depth -> * -> *). [SharedAddressPools key] -> ShowS
forall (key :: Depth -> * -> *). SharedAddressPools key -> String
showList :: [SharedAddressPools key] -> ShowS
$cshowList :: forall (key :: Depth -> * -> *). [SharedAddressPools key] -> ShowS
show :: SharedAddressPools key -> String
$cshow :: forall (key :: Depth -> * -> *). SharedAddressPools key -> String
showsPrec :: Int -> SharedAddressPools key -> ShowS
$cshowsPrec :: forall (key :: Depth -> * -> *).
Int -> SharedAddressPools key -> ShowS
Show)

instance NFData (SharedAddressPools key)

instance Eq (SharedAddressPools key) where
    (SharedAddressPools SharedAddressPool 'UtxoExternal key
ext1 SharedAddressPool 'UtxoInternal key
int1 PendingIxs 'ScriptK
pend1) == :: SharedAddressPools key -> SharedAddressPools key -> Bool
== (SharedAddressPools SharedAddressPool 'UtxoExternal key
ext2 SharedAddressPool 'UtxoInternal key
int2 PendingIxs 'ScriptK
pend2)
        =  Pool (KeyFingerprint "payment" key) (Index 'Soft 'ScriptK)
-> Map
     (KeyFingerprint "payment" key) (Index 'Soft 'ScriptK, AddressState)
forall addr ix. Pool addr ix -> Map addr (ix, AddressState)
AddressPool.addresses (SharedAddressPool 'UtxoInternal key
-> Pool (KeyFingerprint "payment" key) (Index 'Soft 'ScriptK)
forall (c :: Role) (key :: Depth -> * -> *).
SharedAddressPool c key
-> Pool (KeyFingerprint "payment" key) (Index 'Soft 'ScriptK)
getPool SharedAddressPool 'UtxoInternal key
int1) Map
  (KeyFingerprint "payment" key) (Index 'Soft 'ScriptK, AddressState)
-> Map
     (KeyFingerprint "payment" key) (Index 'Soft 'ScriptK, AddressState)
-> Bool
forall a. Eq a => a -> a -> Bool
== Pool (KeyFingerprint "payment" key) (Index 'Soft 'ScriptK)
-> Map
     (KeyFingerprint "payment" key) (Index 'Soft 'ScriptK, AddressState)
forall addr ix. Pool addr ix -> Map addr (ix, AddressState)
AddressPool.addresses (SharedAddressPool 'UtxoInternal key
-> Pool (KeyFingerprint "payment" key) (Index 'Soft 'ScriptK)
forall (c :: Role) (key :: Depth -> * -> *).
SharedAddressPool c key
-> Pool (KeyFingerprint "payment" key) (Index 'Soft 'ScriptK)
getPool SharedAddressPool 'UtxoInternal key
int2)
        Bool -> Bool -> Bool
&& Pool (KeyFingerprint "payment" key) (Index 'Soft 'ScriptK)
-> Map
     (KeyFingerprint "payment" key) (Index 'Soft 'ScriptK, AddressState)
forall addr ix. Pool addr ix -> Map addr (ix, AddressState)
AddressPool.addresses (SharedAddressPool 'UtxoExternal key
-> Pool (KeyFingerprint "payment" key) (Index 'Soft 'ScriptK)
forall (c :: Role) (key :: Depth -> * -> *).
SharedAddressPool c key
-> Pool (KeyFingerprint "payment" key) (Index 'Soft 'ScriptK)
getPool SharedAddressPool 'UtxoExternal key
ext1) Map
  (KeyFingerprint "payment" key) (Index 'Soft 'ScriptK, AddressState)
-> Map
     (KeyFingerprint "payment" key) (Index 'Soft 'ScriptK, AddressState)
-> Bool
forall a. Eq a => a -> a -> Bool
== Pool (KeyFingerprint "payment" key) (Index 'Soft 'ScriptK)
-> Map
     (KeyFingerprint "payment" key) (Index 'Soft 'ScriptK, AddressState)
forall addr ix. Pool addr ix -> Map addr (ix, AddressState)
AddressPool.addresses (SharedAddressPool 'UtxoExternal key
-> Pool (KeyFingerprint "payment" key) (Index 'Soft 'ScriptK)
forall (c :: Role) (key :: Depth -> * -> *).
SharedAddressPool c key
-> Pool (KeyFingerprint "payment" key) (Index 'Soft 'ScriptK)
getPool SharedAddressPool 'UtxoExternal key
ext2)
        Bool -> Bool -> Bool
&& PendingIxs 'ScriptK
pend1 PendingIxs 'ScriptK -> PendingIxs 'ScriptK -> Bool
forall a. Eq a => a -> a -> Bool
== PendingIxs 'ScriptK
pend2

instance Buildable (SharedAddressPools key) where
    build :: SharedAddressPools key -> Builder
build (SharedAddressPools SharedAddressPool 'UtxoExternal key
extPool SharedAddressPool 'UtxoInternal key
intPool PendingIxs 'ScriptK
pending) = Builder
"\n"
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder -> Builder
indentF Int
6 (Builder
"External pool:" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> SharedAddressPool 'UtxoExternal key -> Builder
forall p. Buildable p => p -> Builder
build SharedAddressPool 'UtxoExternal key
extPool)
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder -> Builder
indentF Int
6 (Builder
"Internal pool:" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> SharedAddressPool 'UtxoInternal key -> Builder
forall p. Buildable p => p -> Builder
build SharedAddressPool 'UtxoInternal key
intPool)
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder -> Builder
indentF Int
6 (Builder
"Change indexes: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder -> Builder
indentF Int
4 Builder
chgsF)
      where
        chgsF :: Builder
chgsF = Text
-> (Index 'Soft 'ScriptK -> Builder)
-> [Index 'Soft 'ScriptK]
-> Builder
forall (f :: * -> *) a.
Foldable f =>
Text -> (a -> Builder) -> f a -> Builder
blockListF' Text
"-" Index 'Soft 'ScriptK -> Builder
forall p. Buildable p => p -> Builder
build (PendingIxs 'ScriptK -> [Index 'Soft 'ScriptK]
forall (k :: Depth). PendingIxs k -> [Index 'Soft k]
pendingIxsToList PendingIxs 'ScriptK
pending)

-- | An address pool which keeps track of shared addresses.
-- To create a new pool, see 'newSharedAddressPool'.
newtype SharedAddressPool (c :: Role) (key :: Depth -> Type -> Type) =
    SharedAddressPool {
        SharedAddressPool c key
-> Pool (KeyFingerprint "payment" key) (Index 'Soft 'ScriptK)
getPool ::
            AddressPool.Pool
                (KeyFingerprint "payment" key)
                (Index 'Soft 'ScriptK)
    } deriving ((forall x.
 SharedAddressPool c key -> Rep (SharedAddressPool c key) x)
-> (forall x.
    Rep (SharedAddressPool c key) x -> SharedAddressPool c key)
-> Generic (SharedAddressPool c key)
forall x.
Rep (SharedAddressPool c key) x -> SharedAddressPool c key
forall x.
SharedAddressPool c key -> Rep (SharedAddressPool c key) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (c :: Role) (key :: Depth -> * -> *) x.
Rep (SharedAddressPool c key) x -> SharedAddressPool c key
forall (c :: Role) (key :: Depth -> * -> *) x.
SharedAddressPool c key -> Rep (SharedAddressPool c key) x
$cto :: forall (c :: Role) (key :: Depth -> * -> *) x.
Rep (SharedAddressPool c key) x -> SharedAddressPool c key
$cfrom :: forall (c :: Role) (key :: Depth -> * -> *) x.
SharedAddressPool c key -> Rep (SharedAddressPool c key) x
Generic, Int -> SharedAddressPool c key -> ShowS
[SharedAddressPool c key] -> ShowS
SharedAddressPool c key -> String
(Int -> SharedAddressPool c key -> ShowS)
-> (SharedAddressPool c key -> String)
-> ([SharedAddressPool c key] -> ShowS)
-> Show (SharedAddressPool c key)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (c :: Role) (key :: Depth -> * -> *).
Int -> SharedAddressPool c key -> ShowS
forall (c :: Role) (key :: Depth -> * -> *).
[SharedAddressPool c key] -> ShowS
forall (c :: Role) (key :: Depth -> * -> *).
SharedAddressPool c key -> String
showList :: [SharedAddressPool c key] -> ShowS
$cshowList :: forall (c :: Role) (key :: Depth -> * -> *).
[SharedAddressPool c key] -> ShowS
show :: SharedAddressPool c key -> String
$cshow :: forall (c :: Role) (key :: Depth -> * -> *).
SharedAddressPool c key -> String
showsPrec :: Int -> SharedAddressPool c key -> ShowS
$cshowsPrec :: forall (c :: Role) (key :: Depth -> * -> *).
Int -> SharedAddressPool c key -> ShowS
Show)

instance NFData (SharedAddressPool c k)

instance Buildable (SharedAddressPool c k) where
    build :: SharedAddressPool c k -> Builder
build (SharedAddressPool Pool (KeyFingerprint "payment" k) (Index 'Soft 'ScriptK)
pool) = Pool (KeyFingerprint "payment" k) (Index 'Soft 'ScriptK) -> Builder
forall p. Buildable p => p -> Builder
build Pool (KeyFingerprint "payment" k) (Index 'Soft 'ScriptK)
pool

-- | Create a new shared address pool from complete script templates.
newSharedAddressPool
    :: forall (n :: NetworkDiscriminant) c key.
        ( key ~ SharedKey
        , SupportsDiscovery n key
        , Typeable c )
    => AddressPoolGap
    -> ScriptTemplate
    -> Maybe ScriptTemplate
    -> SharedAddressPool c key
newSharedAddressPool :: AddressPoolGap
-> ScriptTemplate
-> Maybe ScriptTemplate
-> SharedAddressPool c key
newSharedAddressPool AddressPoolGap
g ScriptTemplate
payment Maybe ScriptTemplate
delegation =
    Pool (KeyFingerprint "payment" key) (Index 'Soft 'ScriptK)
-> SharedAddressPool c key
forall (c :: Role) (key :: Depth -> * -> *).
Pool (KeyFingerprint "payment" key) (Index 'Soft 'ScriptK)
-> SharedAddressPool c key
SharedAddressPool (Pool (KeyFingerprint "payment" key) (Index 'Soft 'ScriptK)
 -> SharedAddressPool c key)
-> Pool (KeyFingerprint "payment" key) (Index 'Soft 'ScriptK)
-> SharedAddressPool c key
forall a b. (a -> b) -> a -> b
$ (Index 'Soft 'ScriptK -> KeyFingerprint "payment" key)
-> Int
-> Pool (KeyFingerprint "payment" key) (Index 'Soft 'ScriptK)
forall addr ix.
(Ord addr, Enum ix) =>
(ix -> addr) -> Int -> Pool addr ix
AddressPool.new Index 'Soft 'ScriptK -> KeyFingerprint "payment" key
addressFromIx Int
gap
  where
    gap :: Int
gap = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Word32 -> Int
forall a b. (a -> b) -> a -> b
$ AddressPoolGap -> Word32
getAddressPoolGap AddressPoolGap
g
    addressFromIx :: Index 'Soft 'ScriptK -> KeyFingerprint "payment" key
addressFromIx
        = forall from.
(HasCallStack, MkKeyFingerprint key from) =>
from -> KeyFingerprint "payment" key
forall (k :: Depth -> * -> *) from.
(HasCallStack, MkKeyFingerprint k from) =>
from -> KeyFingerprint "payment" k
unsafePaymentKeyFingerprint @key
        (Address -> KeyFingerprint "payment" key)
-> (Index 'Soft 'ScriptK -> Address)
-> Index 'Soft 'ScriptK
-> KeyFingerprint "payment" key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Role
-> ScriptTemplate
-> Maybe ScriptTemplate
-> Index 'Soft 'ScriptK
-> Address
forall (n :: NetworkDiscriminant).
Typeable n =>
Role
-> ScriptTemplate
-> Maybe ScriptTemplate
-> Index 'Soft 'ScriptK
-> Address
constructAddressFromIx @n (Typeable c => Role
forall (c :: Role). Typeable c => Role
roleVal @c) ScriptTemplate
payment Maybe ScriptTemplate
delegation

{-------------------------------------------------------------------------------
    Shared State
-------------------------------------------------------------------------------}

-- | Shared wallet is a new kind of wallet owned by one or more co-signers.
-- In this type of the wallet, addresses are defined by two monetary scripts
-- (one for the ownership of assets and the other one for the ownership of stake).
-- The two scripts can be the same, different, also the script for the ownership of stake
-- can be absent.
--
-- The shared wallet can be in two states: pending or ready. In a pending state the wallet
-- does not have account public keys for all co-signers, and hence discovery of script addresses
-- co-shared with other co-signers is not possible. In a ready state the wallet has account public
-- keys for all co-signers and co-shared script address discovery is possible.
--
-- The shared wallet is instantiated with an account public key, derivation path needed to
-- recreate it for a holder of this shared wallet, ie., one of the co-signers.
-- In order to construct correctly the wallet, ie., enable co-shared script addresses discovery
-- the following is needed:
--
-- - a way to determine what range of indices are checked on the
--   ledger. Mechanism of address pool, also adopted for sequential wallets,
--   is used. The idea is to track all indices starting from 0 and up to N.
--   N is variable as addresses are discovered (and marked as Used in consequence).
--   The pool of addresses is enlarged in such way that the number of consecutive
--   Unused addresses equals to address pool gap of the address pool. Hence,
--   the address pool gap needs to be specified.
--
-- - script template for payment credential contains information about all collected
--   account public keys for all parties engaged, here named co-signers. Also the skeleton
--   determining script structure is provided. In this sense script is predetermined from
--   the beginning and can variate only in verification key part that replaces co-signers in the
--   script skeleton. The places where a specific cosigner is present is to be replaced
--   with the derived verification key using the co-signer's account public key and
--   the index that was chosen. This is the reason why we need complete set of account public keys for
--   each co-signer to realize address discovery. The script template can be translated into
--   a corresponding script, which hash is used in the address, only when account public keys
--   for all cosigners specified in script are collected.The index for derivation is the same
--   for each cosigner's derivation. The same index is used in both scripts that represent
--   payment or delegation credential. Verification keys are derived
--   using role=3 for payment credential.
--
-- - optional script template for delegation credential contains all information as in case of
--   the script template for payment credential. One difference is that the verification keys are derived
--   using role=4 for delegation credential.
--
-- When both script are present, the base address (with both credentials) is expected to be discovered.
-- When script template for delegation credential is missing then enterprise address (non-stakable) is
-- expected.
data SharedState (n :: NetworkDiscriminant) k = SharedState
    { SharedState n k -> DerivationPrefix
derivationPrefix :: !DerivationPrefix
        -- ^ Derivation path prefix from a root key up to the account key
    , SharedState n k -> k 'AccountK XPub
accountXPub :: !(k 'AccountK XPub)
        -- ^ The account public key of an initiator of the shared wallet
    , SharedState n k -> ScriptTemplate
paymentTemplate :: !ScriptTemplate
        -- ^ Script template together with a map of account keys and cosigners
        -- for payment credential.
    , SharedState n k -> Maybe ScriptTemplate
delegationTemplate :: !(Maybe ScriptTemplate)
        -- ^ Script template together with a map of account keys and cosigners
        -- for staking credential. If not specified then the same template as for
        -- payment is used.
    , SharedState n k -> AddressPoolGap
poolGap :: !AddressPoolGap
        -- ^ Address pool gap to be used in the address pool of shared state
    , SharedState n k -> Readiness (SharedAddressPools k)
ready :: !(Readiness (SharedAddressPools k))
        -- ^ Readiness status of the shared state.
        -- The state is ready if all cosigner public keys have been obtained.
        -- In this case, an address pool is allocated
    } deriving ((forall x. SharedState n k -> Rep (SharedState n k) x)
-> (forall x. Rep (SharedState n k) x -> SharedState n k)
-> Generic (SharedState n k)
forall x. Rep (SharedState n k) x -> SharedState n k
forall x. SharedState n k -> Rep (SharedState n k) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *) x.
Rep (SharedState n k) x -> SharedState n k
forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *) x.
SharedState n k -> Rep (SharedState n k) x
$cto :: forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *) x.
Rep (SharedState n k) x -> SharedState n k
$cfrom :: forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *) x.
SharedState n k -> Rep (SharedState n k) x
Generic)

instance ( NFData (k 'AccountK XPub) ) => NFData (SharedState n k)

deriving instance ( Show (k 'AccountK XPub) ) => Show (SharedState n k)

-- We have to write the equality instance by hands,
-- because there is no general equality for address pools
-- (we cannot test the generators for equality).
instance Eq (k 'AccountK XPub) => Eq (SharedState n k) where
    SharedState DerivationPrefix
a1 k 'AccountK XPub
a2 ScriptTemplate
a3 Maybe ScriptTemplate
a4 AddressPoolGap
a5 Readiness (SharedAddressPools k)
ap == :: SharedState n k -> SharedState n k -> Bool
== SharedState DerivationPrefix
b1 k 'AccountK XPub
b2 ScriptTemplate
b3 Maybe ScriptTemplate
b4 AddressPoolGap
b5 Readiness (SharedAddressPools k)
bp
        = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [DerivationPrefix
a1 DerivationPrefix -> DerivationPrefix -> Bool
forall a. Eq a => a -> a -> Bool
== DerivationPrefix
b1, k 'AccountK XPub
a2 k 'AccountK XPub -> k 'AccountK XPub -> Bool
forall a. Eq a => a -> a -> Bool
== k 'AccountK XPub
b2, ScriptTemplate
a3 ScriptTemplate -> ScriptTemplate -> Bool
forall a. Eq a => a -> a -> Bool
== ScriptTemplate
b3, Maybe ScriptTemplate
a4 Maybe ScriptTemplate -> Maybe ScriptTemplate -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe ScriptTemplate
b4, AddressPoolGap
a5 AddressPoolGap -> AddressPoolGap -> Bool
forall a. Eq a => a -> a -> Bool
== AddressPoolGap
b5, Readiness (SharedAddressPools k)
ap Readiness (SharedAddressPools k)
-> Readiness (SharedAddressPools k) -> Bool
forall a. Eq a => Readiness a -> Readiness a -> Bool
`match` Readiness (SharedAddressPools k)
bp]
      where
        match :: Readiness a -> Readiness a -> Bool
match Readiness a
Pending Readiness a
Pending = Bool
True
        match (Active a
sharedAddressPools1) (Active a
sharedAddressPools2)
            = a
sharedAddressPools1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
sharedAddressPools2
        match Readiness a
_ Readiness a
_ = Bool
False

instance PersistPublicKey (k 'AccountK) => Buildable (SharedState n k) where
    build :: SharedState n k -> Builder
build SharedState n k
st = Builder
"SharedState:\n"
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder -> Builder
indentF Int
4 (Builder
"Derivation prefix: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
forall p. Buildable p => p -> Builder
build (DerivationPrefix -> Text
forall a. ToText a => a -> Text
toText (DerivationPrefix -> Text) -> DerivationPrefix -> Text
forall a b. (a -> b) -> a -> b
$ SharedState n k -> DerivationPrefix
forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
SharedState n k -> DerivationPrefix
derivationPrefix SharedState n k
st))
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder -> Builder
indentF Int
4 (Builder
"accountXPub:" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> k 'AccountK XPub -> Builder
forall p. Buildable p => p -> Builder
build (SharedState n k -> k 'AccountK XPub
forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
SharedState n k -> k 'AccountK XPub
accountXPub SharedState n k
st))
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder -> Builder
indentF Int
4 (Builder
"paymentTemplate:" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ScriptTemplate -> Builder
forall p. Buildable p => p -> Builder
build (SharedState n k -> ScriptTemplate
forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
SharedState n k -> ScriptTemplate
paymentTemplate SharedState n k
st))
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder -> Builder
indentF Int
4 (Builder
"delegationTemplate:" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Maybe ScriptTemplate -> Builder
forall p. Buildable p => p -> Builder
build (SharedState n k -> Maybe ScriptTemplate
forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
SharedState n k -> Maybe ScriptTemplate
delegationTemplate SharedState n k
st))
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder -> Builder
indentF Int
4 (Builder
"poolGap:" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
forall p. Buildable p => p -> Builder
build (AddressPoolGap -> Text
forall a. ToText a => a -> Text
toText (AddressPoolGap -> Text) -> AddressPoolGap -> Text
forall a b. (a -> b) -> a -> b
$ SharedState n k -> AddressPoolGap
forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
SharedState n k -> AddressPoolGap
poolGap SharedState n k
st))
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder -> Builder
indentF Int
4 (Builder
"ready: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Readiness (SharedAddressPools k) -> Builder
readyF (SharedState n k -> Readiness (SharedAddressPools k)
forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
SharedState n k -> Readiness (SharedAddressPools k)
ready SharedState n k
st))
      where
        readyF :: Readiness (SharedAddressPools k) -> Builder
readyF (Readiness (SharedAddressPools k)
Pending) = Builder
"Pending"
        readyF (Active SharedAddressPools k
pool) =
            Builder
"Active:" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> DerivationPrefix -> Builder
printIndex (SharedState n k -> DerivationPrefix
forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
SharedState n k -> DerivationPrefix
derivationPrefix SharedState n k
st) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> SharedAddressPools k -> Builder
forall p. Buildable p => p -> Builder
build SharedAddressPools k
pool
        printIndex :: DerivationPrefix -> Builder
printIndex (DerivationPrefix (Index 'Hardened 'PurposeK
_,Index 'Hardened 'CoinTypeK
_,Index 'Hardened 'AccountK
ix)) =
            Builder
" hardened index: "Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word32 -> Builder
forall p. Buildable p => p -> Builder
build (Index 'Hardened 'AccountK -> Word32
forall (derivationType :: DerivationType) (level :: Depth).
Index derivationType level -> Word32
getIndex Index 'Hardened 'AccountK
ix)

-- | Readiness status of the shared state.
data Readiness a
    = Pending
    | Active !a
    deriving ((forall x. Readiness a -> Rep (Readiness a) x)
-> (forall x. Rep (Readiness a) x -> Readiness a)
-> Generic (Readiness a)
forall x. Rep (Readiness a) x -> Readiness a
forall x. Readiness a -> Rep (Readiness a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Readiness a) x -> Readiness a
forall a x. Readiness a -> Rep (Readiness a) x
$cto :: forall a x. Rep (Readiness a) x -> Readiness a
$cfrom :: forall a x. Readiness a -> Rep (Readiness a) x
Generic, Int -> Readiness a -> ShowS
[Readiness a] -> ShowS
Readiness a -> String
(Int -> Readiness a -> ShowS)
-> (Readiness a -> String)
-> ([Readiness a] -> ShowS)
-> Show (Readiness a)
forall a. Show a => Int -> Readiness a -> ShowS
forall a. Show a => [Readiness a] -> ShowS
forall a. Show a => Readiness a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Readiness a] -> ShowS
$cshowList :: forall a. Show a => [Readiness a] -> ShowS
show :: Readiness a -> String
$cshow :: forall a. Show a => Readiness a -> String
showsPrec :: Int -> Readiness a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Readiness a -> ShowS
Show, Readiness a -> Readiness a -> Bool
(Readiness a -> Readiness a -> Bool)
-> (Readiness a -> Readiness a -> Bool) -> Eq (Readiness a)
forall a. Eq a => Readiness a -> Readiness a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Readiness a -> Readiness a -> Bool
$c/= :: forall a. Eq a => Readiness a -> Readiness a -> Bool
== :: Readiness a -> Readiness a -> Bool
$c== :: forall a. Eq a => Readiness a -> Readiness a -> Bool
Eq)

instance (NFData a) => NFData (Readiness a)

-- | Create a new SharedState from public account key.
mkSharedStateFromAccountXPub
    :: (SupportsDiscovery n k, WalletKey k, k ~ SharedKey)
    => k 'AccountK XPub
    -> Index 'Hardened 'AccountK
    -> AddressPoolGap
    -> ScriptTemplate
    -> Maybe ScriptTemplate
    -> SharedState n k
mkSharedStateFromAccountXPub :: k 'AccountK XPub
-> Index 'Hardened 'AccountK
-> AddressPoolGap
-> ScriptTemplate
-> Maybe ScriptTemplate
-> SharedState n k
mkSharedStateFromAccountXPub k 'AccountK XPub
accXPub Index 'Hardened 'AccountK
accIx AddressPoolGap
gap ScriptTemplate
pTemplate Maybe ScriptTemplate
dTemplateM =
    SharedState n k -> SharedState n k
forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
(SupportsDiscovery n k, WalletKey k, k ~ SharedKey) =>
SharedState n k -> SharedState n k
activate (SharedState n k -> SharedState n k)
-> SharedState n k -> SharedState n k
forall a b. (a -> b) -> a -> b
$ SharedState :: forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
DerivationPrefix
-> k 'AccountK XPub
-> ScriptTemplate
-> Maybe ScriptTemplate
-> AddressPoolGap
-> Readiness (SharedAddressPools k)
-> SharedState n k
SharedState
        { derivationPrefix :: DerivationPrefix
derivationPrefix = (Index 'Hardened 'PurposeK, Index 'Hardened 'CoinTypeK,
 Index 'Hardened 'AccountK)
-> DerivationPrefix
DerivationPrefix (Index 'Hardened 'PurposeK
purposeCIP1854, Index 'Hardened 'CoinTypeK
coinTypeAda, Index 'Hardened 'AccountK
accIx)
        , accountXPub :: k 'AccountK XPub
accountXPub = k 'AccountK XPub
accXPub
        , paymentTemplate :: ScriptTemplate
paymentTemplate = ScriptTemplate
pTemplate
        , delegationTemplate :: Maybe ScriptTemplate
delegationTemplate = Maybe ScriptTemplate
dTemplateM
        , poolGap :: AddressPoolGap
poolGap = AddressPoolGap
gap
        , ready :: Readiness (SharedAddressPools k)
ready = Readiness (SharedAddressPools k)
forall a. Readiness a
Pending
        }

-- | Create a new SharedState from root private key and password.
mkSharedStateFromRootXPrv
    :: (SupportsDiscovery n k, WalletKey k, k ~ SharedKey)
    => (k 'RootK XPrv, Passphrase "encryption")
    -> Index 'Hardened 'AccountK
    -> AddressPoolGap
    -> ScriptTemplate
    -> Maybe ScriptTemplate
    -> SharedState n k
mkSharedStateFromRootXPrv :: (k 'RootK XPrv, Passphrase "encryption")
-> Index 'Hardened 'AccountK
-> AddressPoolGap
-> ScriptTemplate
-> Maybe ScriptTemplate
-> SharedState n k
mkSharedStateFromRootXPrv (k 'RootK XPrv
rootXPrv, Passphrase "encryption"
pwd) Index 'Hardened 'AccountK
accIx =
    k 'AccountK XPub
-> Index 'Hardened 'AccountK
-> AddressPoolGap
-> ScriptTemplate
-> Maybe ScriptTemplate
-> SharedState n k
forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
(SupportsDiscovery n k, WalletKey k, k ~ SharedKey) =>
k 'AccountK XPub
-> Index 'Hardened 'AccountK
-> AddressPoolGap
-> ScriptTemplate
-> Maybe ScriptTemplate
-> SharedState n k
mkSharedStateFromAccountXPub k 'AccountK XPub
accXPub Index 'Hardened 'AccountK
accIx
  where
    accXPub :: k 'AccountK XPub
accXPub = k 'AccountK XPrv -> k 'AccountK XPub
forall (key :: Depth -> * -> *) (depth :: Depth).
WalletKey key =>
key depth XPrv -> key depth XPub
publicKey (k 'AccountK XPrv -> k 'AccountK XPub)
-> k 'AccountK XPrv -> k 'AccountK XPub
forall a b. (a -> b) -> a -> b
$ Passphrase "encryption"
-> k 'RootK XPrv -> Index 'Hardened 'AccountK -> k 'AccountK XPrv
forall (key :: Depth -> * -> *).
HardDerivation key =>
Passphrase "encryption"
-> key 'RootK XPrv
-> Index 'Hardened 'AccountK
-> key 'AccountK XPrv
deriveAccountPrivateKey Passphrase "encryption"
pwd k 'RootK XPrv
rootXPrv Index 'Hardened 'AccountK
accIx

-- | Turn a 'Pending' into an 'Active' state if all templates are complete.
activate
    :: forall n k. (SupportsDiscovery n k, WalletKey k, k ~ SharedKey)
    => SharedState n k -> SharedState n k
activate :: SharedState n k -> SharedState n k
activate
    st :: SharedState n k
st@(SharedState{k 'AccountK XPub
accountXPub :: k 'AccountK XPub
accountXPub :: forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
SharedState n k -> k 'AccountK XPub
accountXPub,paymentTemplate :: forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
SharedState n k -> ScriptTemplate
paymentTemplate=ScriptTemplate
pT,delegationTemplate :: forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
SharedState n k -> Maybe ScriptTemplate
delegationTemplate=Maybe ScriptTemplate
dT,AddressPoolGap
poolGap :: AddressPoolGap
poolGap :: forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
SharedState n k -> AddressPoolGap
poolGap,Readiness (SharedAddressPools k)
ready :: Readiness (SharedAddressPools k)
ready :: forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
SharedState n k -> Readiness (SharedAddressPools k)
ready})
  = SharedState n k
st { ready :: Readiness (SharedAddressPools k)
ready = Readiness (SharedAddressPools k)
-> Readiness (SharedAddressPools k)
new Readiness (SharedAddressPools k)
ready }
  where
    new :: Readiness (SharedAddressPools k)
-> Readiness (SharedAddressPools k)
new Readiness (SharedAddressPools k)
Pending
        | k 'AccountK XPub -> ScriptTemplate -> Maybe ScriptTemplate -> Bool
forall (k :: Depth -> * -> *).
WalletKey k =>
k 'AccountK XPub -> ScriptTemplate -> Maybe ScriptTemplate -> Bool
templatesComplete k 'AccountK XPub
accountXPub ScriptTemplate
pT Maybe ScriptTemplate
dT
            = SharedAddressPools k -> Readiness (SharedAddressPools k)
forall a. a -> Readiness a
Active (SharedAddressPools k -> Readiness (SharedAddressPools k))
-> SharedAddressPools k -> Readiness (SharedAddressPools k)
forall a b. (a -> b) -> a -> b
$ SharedAddressPools :: forall (key :: Depth -> * -> *).
SharedAddressPool 'UtxoExternal key
-> SharedAddressPool 'UtxoInternal key
-> PendingIxs 'ScriptK
-> SharedAddressPools key
SharedAddressPools
              { externalPool :: SharedAddressPool 'UtxoExternal k
externalPool = AddressPoolGap
-> ScriptTemplate
-> Maybe ScriptTemplate
-> SharedAddressPool 'UtxoExternal k
forall (n :: NetworkDiscriminant) (c :: Role)
       (key :: Depth -> * -> *).
(key ~ SharedKey, SupportsDiscovery n key, Typeable c) =>
AddressPoolGap
-> ScriptTemplate
-> Maybe ScriptTemplate
-> SharedAddressPool c key
newSharedAddressPool @n AddressPoolGap
poolGap ScriptTemplate
pT Maybe ScriptTemplate
dT
              , internalPool :: SharedAddressPool 'UtxoInternal k
internalPool = AddressPoolGap
-> ScriptTemplate
-> Maybe ScriptTemplate
-> SharedAddressPool 'UtxoInternal k
forall (n :: NetworkDiscriminant) (c :: Role)
       (key :: Depth -> * -> *).
(key ~ SharedKey, SupportsDiscovery n key, Typeable c) =>
AddressPoolGap
-> ScriptTemplate
-> Maybe ScriptTemplate
-> SharedAddressPool c key
newSharedAddressPool @n AddressPoolGap
poolGap ScriptTemplate
pT Maybe ScriptTemplate
dT
              , pendingChangeIxs :: PendingIxs 'ScriptK
pendingChangeIxs = PendingIxs 'ScriptK
forall (k :: Depth). PendingIxs k
emptyPendingIxs
              }
    new Readiness (SharedAddressPools k)
r   = Readiness (SharedAddressPools k)
r

-- | Possible errors from adding a co-signer key to the shared wallet state.
data ErrAddCosigner
    = NoDelegationTemplate
        -- ^ Adding key for a cosigner for a non-existent delegation template is
        -- not allowed.
    | NoSuchCosigner CredentialType Cosigner
        -- ^ Adding key for a cosigners for a given script is possible for the
        -- cosigner present in the script template.
    | KeyAlreadyPresent CredentialType
        -- ^ Adding the same key for different cosigners for a given script is
        -- not allowed.
    | WalletAlreadyActive
        -- ^ Adding is possible only to pending shared wallet.
    | CannotUpdateSharedWalletKey
        -- ^ Updating key is possible only for other cosigners, not cosigner
        -- belonging to the shared wallet.
    deriving (ErrAddCosigner -> ErrAddCosigner -> Bool
(ErrAddCosigner -> ErrAddCosigner -> Bool)
-> (ErrAddCosigner -> ErrAddCosigner -> Bool) -> Eq ErrAddCosigner
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrAddCosigner -> ErrAddCosigner -> Bool
$c/= :: ErrAddCosigner -> ErrAddCosigner -> Bool
== :: ErrAddCosigner -> ErrAddCosigner -> Bool
$c== :: ErrAddCosigner -> ErrAddCosigner -> Bool
Eq, Int -> ErrAddCosigner -> ShowS
[ErrAddCosigner] -> ShowS
ErrAddCosigner -> String
(Int -> ErrAddCosigner -> ShowS)
-> (ErrAddCosigner -> String)
-> ([ErrAddCosigner] -> ShowS)
-> Show ErrAddCosigner
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrAddCosigner] -> ShowS
$cshowList :: [ErrAddCosigner] -> ShowS
show :: ErrAddCosigner -> String
$cshow :: ErrAddCosigner -> String
showsPrec :: Int -> ErrAddCosigner -> ShowS
$cshowsPrec :: Int -> ErrAddCosigner -> ShowS
Show)

-- | The cosigner with his account public key is updated per template.
--
-- For each template the script is checked for presence of the cosigner:
--   * If present, then the key is inserted into the state.
--   * Otherwise, fail with 'NoSuchCosigner'.
-- If the key is already present it is going to be updated.
-- For a given template all keys must be unique. If already present key is tried to be added,
-- `KeyAlreadyPresent` error is produced. The updating works only with pending shared state,
--
-- When an active shared state is used `WalletAlreadyActive` error is triggered.
--
-- Updating the key for delegation script can be successful only if delegation script is
-- present. Otherwise, `NoDelegationTemplate` error is triggered.
addCosignerAccXPub
    :: (SupportsDiscovery n k, WalletKey k, k ~ SharedKey)
    => (Cosigner, k 'AccountK XPub)
    -> CredentialType
    -> SharedState n k
    -> Either ErrAddCosigner (SharedState n k)
addCosignerAccXPub :: (Cosigner, k 'AccountK XPub)
-> CredentialType
-> SharedState n k
-> Either ErrAddCosigner (SharedState n k)
addCosignerAccXPub (Cosigner
cosigner, k 'AccountK XPub
cosignerXPub) CredentialType
cred SharedState n k
st = case SharedState n k -> Readiness (SharedAddressPools k)
forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
SharedState n k -> Readiness (SharedAddressPools k)
ready SharedState n k
st of
    Active{} ->
        ErrAddCosigner -> Either ErrAddCosigner (SharedState n k)
forall a b. a -> Either a b
Left ErrAddCosigner
WalletAlreadyActive
    Readiness (SharedAddressPools k)
Pending ->
        case (CredentialType
cred, SharedState n k -> ScriptTemplate
forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
SharedState n k -> ScriptTemplate
paymentTemplate SharedState n k
st, SharedState n k -> Maybe ScriptTemplate
forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
SharedState n k -> Maybe ScriptTemplate
delegationTemplate SharedState n k
st) of
            (CredentialType
Payment, ScriptTemplate
pt, Maybe ScriptTemplate
_)
                | ScriptTemplate -> Bool
tryingUpdateWalletCosigner ScriptTemplate
pt -> ErrAddCosigner -> Either ErrAddCosigner (SharedState n k)
forall a b. a -> Either a b
Left ErrAddCosigner
CannotUpdateSharedWalletKey
                | ScriptTemplate -> Bool
isCosignerMissing ScriptTemplate
pt -> ErrAddCosigner -> Either ErrAddCosigner (SharedState n k)
forall a b. a -> Either a b
Left (ErrAddCosigner -> Either ErrAddCosigner (SharedState n k))
-> ErrAddCosigner -> Either ErrAddCosigner (SharedState n k)
forall a b. (a -> b) -> a -> b
$ CredentialType -> Cosigner -> ErrAddCosigner
NoSuchCosigner CredentialType
cred Cosigner
cosigner
                | ScriptTemplate -> Bool
isKeyAlreadyPresent ScriptTemplate
pt -> ErrAddCosigner -> Either ErrAddCosigner (SharedState n k)
forall a b. a -> Either a b
Left (ErrAddCosigner -> Either ErrAddCosigner (SharedState n k))
-> ErrAddCosigner -> Either ErrAddCosigner (SharedState n k)
forall a b. (a -> b) -> a -> b
$ CredentialType -> ErrAddCosigner
KeyAlreadyPresent CredentialType
cred
            (CredentialType
Delegation, ScriptTemplate
_, Just ScriptTemplate
dt)
                | ScriptTemplate -> Bool
tryingUpdateWalletCosigner ScriptTemplate
dt -> ErrAddCosigner -> Either ErrAddCosigner (SharedState n k)
forall a b. a -> Either a b
Left ErrAddCosigner
CannotUpdateSharedWalletKey
                | ScriptTemplate -> Bool
isCosignerMissing ScriptTemplate
dt -> ErrAddCosigner -> Either ErrAddCosigner (SharedState n k)
forall a b. a -> Either a b
Left (ErrAddCosigner -> Either ErrAddCosigner (SharedState n k))
-> ErrAddCosigner -> Either ErrAddCosigner (SharedState n k)
forall a b. (a -> b) -> a -> b
$ CredentialType -> Cosigner -> ErrAddCosigner
NoSuchCosigner CredentialType
cred Cosigner
cosigner
                | ScriptTemplate -> Bool
isKeyAlreadyPresent ScriptTemplate
dt -> ErrAddCosigner -> Either ErrAddCosigner (SharedState n k)
forall a b. a -> Either a b
Left (ErrAddCosigner -> Either ErrAddCosigner (SharedState n k))
-> ErrAddCosigner -> Either ErrAddCosigner (SharedState n k)
forall a b. (a -> b) -> a -> b
$ CredentialType -> ErrAddCosigner
KeyAlreadyPresent CredentialType
cred
            (CredentialType
Delegation, ScriptTemplate
_, Maybe ScriptTemplate
Nothing) -> ErrAddCosigner -> Either ErrAddCosigner (SharedState n k)
forall a b. a -> Either a b
Left ErrAddCosigner
NoDelegationTemplate
            (CredentialType, ScriptTemplate, Maybe ScriptTemplate)
_ -> SharedState n k -> Either ErrAddCosigner (SharedState n k)
forall a b. b -> Either a b
Right (SharedState n k -> Either ErrAddCosigner (SharedState n k))
-> SharedState n k -> Either ErrAddCosigner (SharedState n k)
forall a b. (a -> b) -> a -> b
$
                SharedState n k -> SharedState n k
forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
(SupportsDiscovery n k, WalletKey k, k ~ SharedKey) =>
SharedState n k -> SharedState n k
activate (SharedState n k -> SharedState n k)
-> SharedState n k -> SharedState n k
forall a b. (a -> b) -> a -> b
$ (Cosigner, k 'AccountK XPub)
-> CredentialType -> SharedState n k -> SharedState n k
forall (k :: Depth -> * -> *) (n :: NetworkDiscriminant).
WalletKey k =>
(Cosigner, k 'AccountK XPub)
-> CredentialType -> SharedState n k -> SharedState n k
addCosignerPending (Cosigner
cosigner, k 'AccountK XPub
cosignerXPub) CredentialType
cred SharedState n k
st
  where
    walletKey :: k 'AccountK XPub
walletKey = SharedState n k -> k 'AccountK XPub
forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
SharedState n k -> k 'AccountK XPub
accountXPub SharedState n k
st
    isKeyAlreadyPresent :: ScriptTemplate -> Bool
isKeyAlreadyPresent (ScriptTemplate Map Cosigner XPub
cosignerKeys Script Cosigner
_) =
        k 'AccountK XPub -> XPub
forall (key :: Depth -> * -> *) (depth :: Depth) raw.
WalletKey key =>
key depth raw -> raw
getRawKey k 'AccountK XPub
cosignerXPub XPub -> Map Cosigner XPub -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`F.elem` Map Cosigner XPub
cosignerKeys
    isCosignerMissing :: ScriptTemplate -> Bool
isCosignerMissing (ScriptTemplate Map Cosigner XPub
_ Script Cosigner
script') =
        Cosigner
cosigner Cosigner -> [Cosigner] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` Script Cosigner -> [Cosigner]
retrieveAllCosigners Script Cosigner
script'
    tryingUpdateWalletCosigner :: ScriptTemplate -> Bool
tryingUpdateWalletCosigner (ScriptTemplate Map Cosigner XPub
cosignerKeys Script Cosigner
_) =
        case Cosigner -> Map Cosigner XPub -> Maybe XPub
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Cosigner
cosigner Map Cosigner XPub
cosignerKeys of
            Maybe XPub
Nothing -> Bool
False
            Just XPub
key' -> XPub
key' XPub -> XPub -> Bool
forall a. Eq a => a -> a -> Bool
== k 'AccountK XPub -> XPub
forall (key :: Depth -> * -> *) (depth :: Depth) raw.
WalletKey key =>
key depth raw -> raw
getRawKey k 'AccountK XPub
walletKey

addCosignerPending
    :: WalletKey k
    => (Cosigner, k 'AccountK XPub)
    -> CredentialType
    -> SharedState n k
    -> SharedState n k
addCosignerPending :: (Cosigner, k 'AccountK XPub)
-> CredentialType -> SharedState n k -> SharedState n k
addCosignerPending (Cosigner
cosigner, k 'AccountK XPub
cosignerXPub) CredentialType
cred SharedState n k
st = case CredentialType
cred of
    CredentialType
Payment ->
        SharedState n k
st { paymentTemplate :: ScriptTemplate
paymentTemplate = ScriptTemplate -> ScriptTemplate
updateScriptTemplate (SharedState n k -> ScriptTemplate
forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
SharedState n k -> ScriptTemplate
paymentTemplate SharedState n k
st) }
    CredentialType
Delegation ->
        SharedState n k
st { delegationTemplate :: Maybe ScriptTemplate
delegationTemplate = ScriptTemplate -> ScriptTemplate
updateScriptTemplate (ScriptTemplate -> ScriptTemplate)
-> Maybe ScriptTemplate -> Maybe ScriptTemplate
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SharedState n k -> Maybe ScriptTemplate
forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
SharedState n k -> Maybe ScriptTemplate
delegationTemplate SharedState n k
st) }
  where
    updateScriptTemplate :: ScriptTemplate -> ScriptTemplate
updateScriptTemplate sc :: ScriptTemplate
sc@(ScriptTemplate Map Cosigner XPub
cosignerMap Script Cosigner
script')
        | Cosigner
cosigner Cosigner -> [Cosigner] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Script Cosigner -> [Cosigner]
retrieveAllCosigners Script Cosigner
script' =
            Map Cosigner XPub -> Script Cosigner -> ScriptTemplate
ScriptTemplate (Cosigner -> XPub -> Map Cosigner XPub -> Map Cosigner XPub
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Cosigner
cosigner (k 'AccountK XPub -> XPub
forall (key :: Depth -> * -> *) (depth :: Depth) raw.
WalletKey key =>
key depth raw -> raw
getRawKey k 'AccountK XPub
cosignerXPub) Map Cosigner XPub
cosignerMap) Script Cosigner
script'
        | Bool
otherwise = ScriptTemplate
sc

retrieveAllCosigners :: Script Cosigner -> [Cosigner]
retrieveAllCosigners :: Script Cosigner -> [Cosigner]
retrieveAllCosigners = (Cosigner -> [Cosigner] -> [Cosigner])
-> [Cosigner] -> Script Cosigner -> [Cosigner]
forall a b. (a -> b -> b) -> b -> Script a -> b
foldScript (:) []

{-------------------------------------------------------------------------------
    Template validation
-------------------------------------------------------------------------------}

-- | Is the given account public key among the cosigners?
accountXPubCondition
    :: WalletKey k
    => k 'AccountK XPub
    -> ScriptTemplate
    -> Bool
accountXPubCondition :: k 'AccountK XPub -> ScriptTemplate -> Bool
accountXPubCondition k 'AccountK XPub
accXPub (ScriptTemplate Map Cosigner XPub
cosignerKeys Script Cosigner
_) =
    k 'AccountK XPub -> XPub
forall (key :: Depth -> * -> *) (depth :: Depth) raw.
WalletKey key =>
key depth raw -> raw
getRawKey k 'AccountK XPub
accXPub XPub -> Map Cosigner XPub -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`F.elem` Map Cosigner XPub
cosignerKeys

data ErrScriptTemplate =
      ErrScriptTemplateInvalid !CredentialType !ErrValidateScriptTemplate
    | ErrScriptTemplateMissingKey !CredentialType !Text
    deriving (Int -> ErrScriptTemplate -> ShowS
[ErrScriptTemplate] -> ShowS
ErrScriptTemplate -> String
(Int -> ErrScriptTemplate -> ShowS)
-> (ErrScriptTemplate -> String)
-> ([ErrScriptTemplate] -> ShowS)
-> Show ErrScriptTemplate
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrScriptTemplate] -> ShowS
$cshowList :: [ErrScriptTemplate] -> ShowS
show :: ErrScriptTemplate -> String
$cshow :: ErrScriptTemplate -> String
showsPrec :: Int -> ErrScriptTemplate -> ShowS
$cshowsPrec :: Int -> ErrScriptTemplate -> ShowS
Show, ErrScriptTemplate -> ErrScriptTemplate -> Bool
(ErrScriptTemplate -> ErrScriptTemplate -> Bool)
-> (ErrScriptTemplate -> ErrScriptTemplate -> Bool)
-> Eq ErrScriptTemplate
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrScriptTemplate -> ErrScriptTemplate -> Bool
$c/= :: ErrScriptTemplate -> ErrScriptTemplate -> Bool
== :: ErrScriptTemplate -> ErrScriptTemplate -> Bool
$c== :: ErrScriptTemplate -> ErrScriptTemplate -> Bool
Eq)

instance ToText ErrValidateScriptTemplate where
    toText :: ErrValidateScriptTemplate -> Text
toText = String -> Text
T.pack (String -> Text)
-> (ErrValidateScriptTemplate -> String)
-> ErrValidateScriptTemplate
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrValidateScriptTemplate -> String
prettyErrValidateScriptTemplate

validateScriptTemplates
    :: WalletKey k
    => k 'AccountK XPub
    -> ValidationLevel
    -> ScriptTemplate
    -> Maybe ScriptTemplate
    -> Either ErrScriptTemplate ()
validateScriptTemplates :: k 'AccountK XPub
-> ValidationLevel
-> ScriptTemplate
-> Maybe ScriptTemplate
-> Either ErrScriptTemplate ()
validateScriptTemplates k 'AccountK XPub
accXPub ValidationLevel
level ScriptTemplate
pTemplate Maybe ScriptTemplate
dTemplateM = do
    CredentialType -> ScriptTemplate -> Either ErrScriptTemplate ()
checkTemplate CredentialType
Payment ScriptTemplate
pTemplate
    Bool -> Either ErrScriptTemplate () -> Either ErrScriptTemplate ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ScriptTemplate -> Bool
checkXPub ScriptTemplate
pTemplate) (Either ErrScriptTemplate () -> Either ErrScriptTemplate ())
-> Either ErrScriptTemplate () -> Either ErrScriptTemplate ()
forall a b. (a -> b) -> a -> b
$ ErrScriptTemplate -> Either ErrScriptTemplate ()
forall a b. a -> Either a b
Left (ErrScriptTemplate -> Either ErrScriptTemplate ())
-> ErrScriptTemplate -> Either ErrScriptTemplate ()
forall a b. (a -> b) -> a -> b
$ CredentialType -> Text -> ErrScriptTemplate
ErrScriptTemplateMissingKey CredentialType
Payment Text
accXPubErr
    case Maybe ScriptTemplate
dTemplateM of
        Just ScriptTemplate
dTemplate -> do
            CredentialType -> ScriptTemplate -> Either ErrScriptTemplate ()
checkTemplate CredentialType
Delegation ScriptTemplate
dTemplate
            Bool -> Either ErrScriptTemplate () -> Either ErrScriptTemplate ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ScriptTemplate -> Bool
checkXPub ScriptTemplate
dTemplate) (Either ErrScriptTemplate () -> Either ErrScriptTemplate ())
-> Either ErrScriptTemplate () -> Either ErrScriptTemplate ()
forall a b. (a -> b) -> a -> b
$ ErrScriptTemplate -> Either ErrScriptTemplate ()
forall a b. a -> Either a b
Left (ErrScriptTemplate -> Either ErrScriptTemplate ())
-> ErrScriptTemplate -> Either ErrScriptTemplate ()
forall a b. (a -> b) -> a -> b
$ CredentialType -> Text -> ErrScriptTemplate
ErrScriptTemplateMissingKey CredentialType
Delegation Text
accXPubErr
        Maybe ScriptTemplate
Nothing -> () -> Either ErrScriptTemplate ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
      --when creating the shared wallet we can have cosigners in script with missing
      --account public key. They are supposed to be collected when patching.
      handleUnusedCosigner
          :: Either ErrValidateScriptTemplate ()
          -> Either ErrValidateScriptTemplate ()
      handleUnusedCosigner :: Either ErrValidateScriptTemplate ()
-> Either ErrValidateScriptTemplate ()
handleUnusedCosigner = \case
          Left ErrValidateScriptTemplate
MissingCosignerXPub -> () -> Either ErrValidateScriptTemplate ()
forall a b. b -> Either a b
Right ()
          Either ErrValidateScriptTemplate ()
rest -> Either ErrValidateScriptTemplate ()
rest
      checkTemplate :: CredentialType -> ScriptTemplate -> Either ErrScriptTemplate ()
checkTemplate CredentialType
cred ScriptTemplate
template' =
          (ErrValidateScriptTemplate -> ErrScriptTemplate)
-> Either ErrValidateScriptTemplate ()
-> Either ErrScriptTemplate ()
forall a c b. (a -> c) -> Either a b -> Either c b
mapLeft (CredentialType -> ErrValidateScriptTemplate -> ErrScriptTemplate
ErrScriptTemplateInvalid CredentialType
cred) (Either ErrValidateScriptTemplate ()
 -> Either ErrScriptTemplate ())
-> Either ErrValidateScriptTemplate ()
-> Either ErrScriptTemplate ()
forall a b. (a -> b) -> a -> b
$
          Either ErrValidateScriptTemplate ()
-> Either ErrValidateScriptTemplate ()
handleUnusedCosigner (Either ErrValidateScriptTemplate ()
 -> Either ErrValidateScriptTemplate ())
-> Either ErrValidateScriptTemplate ()
-> Either ErrValidateScriptTemplate ()
forall a b. (a -> b) -> a -> b
$
          ValidationLevel
-> ScriptTemplate -> Either ErrValidateScriptTemplate ()
validateScriptTemplate ValidationLevel
level ScriptTemplate
template'
      checkXPub :: ScriptTemplate -> Bool
checkXPub ScriptTemplate
template' =
          k 'AccountK XPub -> ScriptTemplate -> Bool
forall (k :: Depth -> * -> *).
WalletKey k =>
k 'AccountK XPub -> ScriptTemplate -> Bool
accountXPubCondition k 'AccountK XPub
accXPub ScriptTemplate
template'
      accXPubErr :: Text
accXPubErr = Text
"The wallet's account key must be always present for the script template."

-- | Do we have all public keys in the templates?
templatesComplete
    :: WalletKey k
    => k 'AccountK XPub
    -> ScriptTemplate
    -> Maybe ScriptTemplate
    -> Bool
templatesComplete :: k 'AccountK XPub -> ScriptTemplate -> Maybe ScriptTemplate -> Bool
templatesComplete k 'AccountK XPub
accXPub ScriptTemplate
pTemplate Maybe ScriptTemplate
dTemplate =
    ScriptTemplate -> Bool
isValid ScriptTemplate
pTemplate Bool -> Bool -> Bool
&& Bool -> (ScriptTemplate -> Bool) -> Maybe ScriptTemplate -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True ScriptTemplate -> Bool
isValid Maybe ScriptTemplate
dTemplate
  where
    isValid :: ScriptTemplate -> Bool
isValid ScriptTemplate
template' =
        Either ErrValidateScriptTemplate () -> Bool
forall a b. Either a b -> Bool
isRight (ValidationLevel
-> ScriptTemplate -> Either ErrValidateScriptTemplate ()
validateScriptTemplate ValidationLevel
RequiredValidation ScriptTemplate
template')
        Bool -> Bool -> Bool
&& (k 'AccountK XPub -> ScriptTemplate -> Bool
forall (k :: Depth -> * -> *).
WalletKey k =>
k 'AccountK XPub -> ScriptTemplate -> Bool
accountXPubCondition k 'AccountK XPub
accXPub ScriptTemplate
template')

{-------------------------------------------------------------------------------
    Address discovery
-------------------------------------------------------------------------------}

isShared
    :: SupportsDiscovery n k
    => Address
    -> SharedState n k
    -> (Maybe (Index 'Soft 'ScriptK), SharedState n k)
isShared :: Address
-> SharedState n k
-> (Maybe (Index 'Soft 'ScriptK), SharedState n k)
isShared Address
addrRaw SharedState n k
st = case SharedState n k -> Readiness (SharedAddressPools k)
forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
SharedState n k -> Readiness (SharedAddressPools k)
ready SharedState n k
st of
    Readiness (SharedAddressPools k)
Pending -> (Maybe (Index 'Soft 'ScriptK), SharedState n k)
nop
    Active (SharedAddressPools SharedAddressPool 'UtxoExternal k
extPool SharedAddressPool 'UtxoInternal k
intPool PendingIxs 'ScriptK
pending) ->
        case Address
-> Either
     (ErrMkKeyFingerprint k Address) (KeyFingerprint "payment" k)
forall (key :: Depth -> * -> *) from.
MkKeyFingerprint key from =>
from
-> Either
     (ErrMkKeyFingerprint key from) (KeyFingerprint "payment" key)
paymentKeyFingerprint Address
addrRaw of
            Left ErrMkKeyFingerprint k Address
_ -> (Maybe (Index 'Soft 'ScriptK), SharedState n k)
nop
            Right KeyFingerprint "payment" k
addr -> case ( KeyFingerprint "payment" k
-> Pool (KeyFingerprint "payment" k) (Index 'Soft 'ScriptK)
-> Maybe (Index 'Soft 'ScriptK)
forall addr ix. Ord addr => addr -> Pool addr ix -> Maybe ix
AddressPool.lookup KeyFingerprint "payment" k
addr (SharedAddressPool 'UtxoExternal k
-> Pool (KeyFingerprint "payment" k) (Index 'Soft 'ScriptK)
forall (c :: Role) (key :: Depth -> * -> *).
SharedAddressPool c key
-> Pool (KeyFingerprint "payment" key) (Index 'Soft 'ScriptK)
getPool SharedAddressPool 'UtxoExternal k
extPool)
                               , KeyFingerprint "payment" k
-> Pool (KeyFingerprint "payment" k) (Index 'Soft 'ScriptK)
-> Maybe (Index 'Soft 'ScriptK)
forall addr ix. Ord addr => addr -> Pool addr ix -> Maybe ix
AddressPool.lookup KeyFingerprint "payment" k
addr (SharedAddressPool 'UtxoInternal k
-> Pool (KeyFingerprint "payment" k) (Index 'Soft 'ScriptK)
forall (c :: Role) (key :: Depth -> * -> *).
SharedAddressPool c key
-> Pool (KeyFingerprint "payment" key) (Index 'Soft 'ScriptK)
getPool SharedAddressPool 'UtxoInternal k
intPool)) of
                (Just Index 'Soft 'ScriptK
ix, Maybe (Index 'Soft 'ScriptK)
Nothing) ->
                    let pool' :: Pool (KeyFingerprint "payment" k) (Index 'Soft 'ScriptK)
pool' = KeyFingerprint "payment" k
-> Pool (KeyFingerprint "payment" k) (Index 'Soft 'ScriptK)
-> Pool (KeyFingerprint "payment" k) (Index 'Soft 'ScriptK)
forall addr ix.
(Ord addr, Enum ix) =>
addr -> Pool addr ix -> Pool addr ix
AddressPool.update KeyFingerprint "payment" k
addr (SharedAddressPool 'UtxoExternal k
-> Pool (KeyFingerprint "payment" k) (Index 'Soft 'ScriptK)
forall (c :: Role) (key :: Depth -> * -> *).
SharedAddressPool c key
-> Pool (KeyFingerprint "payment" key) (Index 'Soft 'ScriptK)
getPool SharedAddressPool 'UtxoExternal k
extPool) in
                    ( Index 'Soft 'ScriptK -> Maybe (Index 'Soft 'ScriptK)
forall a. a -> Maybe a
Just Index 'Soft 'ScriptK
ix
                    , SharedState n k
st { ready :: Readiness (SharedAddressPools k)
ready = SharedAddressPools k -> Readiness (SharedAddressPools k)
forall a. a -> Readiness a
Active
                             ( SharedAddressPool 'UtxoExternal k
-> SharedAddressPool 'UtxoInternal k
-> PendingIxs 'ScriptK
-> SharedAddressPools k
forall (key :: Depth -> * -> *).
SharedAddressPool 'UtxoExternal key
-> SharedAddressPool 'UtxoInternal key
-> PendingIxs 'ScriptK
-> SharedAddressPools key
SharedAddressPools
                                 (Pool (KeyFingerprint "payment" k) (Index 'Soft 'ScriptK)
-> SharedAddressPool 'UtxoExternal k
forall (c :: Role) (key :: Depth -> * -> *).
Pool (KeyFingerprint "payment" key) (Index 'Soft 'ScriptK)
-> SharedAddressPool c key
SharedAddressPool Pool (KeyFingerprint "payment" k) (Index 'Soft 'ScriptK)
pool')
                                 SharedAddressPool 'UtxoInternal k
intPool
                                 PendingIxs 'ScriptK
pending )
                         } )
                (Maybe (Index 'Soft 'ScriptK)
Nothing, Just Index 'Soft 'ScriptK
ix) ->
                    let pool' :: Pool (KeyFingerprint "payment" k) (Index 'Soft 'ScriptK)
pool' = KeyFingerprint "payment" k
-> Pool (KeyFingerprint "payment" k) (Index 'Soft 'ScriptK)
-> Pool (KeyFingerprint "payment" k) (Index 'Soft 'ScriptK)
forall addr ix.
(Ord addr, Enum ix) =>
addr -> Pool addr ix -> Pool addr ix
AddressPool.update KeyFingerprint "payment" k
addr (SharedAddressPool 'UtxoInternal k
-> Pool (KeyFingerprint "payment" k) (Index 'Soft 'ScriptK)
forall (c :: Role) (key :: Depth -> * -> *).
SharedAddressPool c key
-> Pool (KeyFingerprint "payment" key) (Index 'Soft 'ScriptK)
getPool SharedAddressPool 'UtxoInternal k
intPool) in
                    ( Index 'Soft 'ScriptK -> Maybe (Index 'Soft 'ScriptK)
forall a. a -> Maybe a
Just Index 'Soft 'ScriptK
ix
                    , SharedState n k
st { ready :: Readiness (SharedAddressPools k)
ready = SharedAddressPools k -> Readiness (SharedAddressPools k)
forall a. a -> Readiness a
Active
                             ( SharedAddressPool 'UtxoExternal k
-> SharedAddressPool 'UtxoInternal k
-> PendingIxs 'ScriptK
-> SharedAddressPools k
forall (key :: Depth -> * -> *).
SharedAddressPool 'UtxoExternal key
-> SharedAddressPool 'UtxoInternal key
-> PendingIxs 'ScriptK
-> SharedAddressPools key
SharedAddressPools
                                 SharedAddressPool 'UtxoExternal k
extPool
                                 (Pool (KeyFingerprint "payment" k) (Index 'Soft 'ScriptK)
-> SharedAddressPool 'UtxoInternal k
forall (c :: Role) (key :: Depth -> * -> *).
Pool (KeyFingerprint "payment" key) (Index 'Soft 'ScriptK)
-> SharedAddressPool c key
SharedAddressPool Pool (KeyFingerprint "payment" k) (Index 'Soft 'ScriptK)
pool')
                                 PendingIxs 'ScriptK
pending )
                         } )
                (Maybe (Index 'Soft 'ScriptK), Maybe (Index 'Soft 'ScriptK))
_ -> (Maybe (Index 'Soft 'ScriptK), SharedState n k)
nop
  where
    nop :: (Maybe (Index 'Soft 'ScriptK), SharedState n k)
nop = (Maybe (Index 'Soft 'ScriptK)
forall a. Maybe a
Nothing, SharedState n k
st)
    -- FIXME: Check that the network discrimant of the type
    -- is compatible with the discriminant of the Address!

instance SupportsDiscovery n k => IsOurs (SharedState n k) Address
  where
    isOurs :: Address
-> SharedState n k
-> (Maybe (NonEmpty DerivationIndex), SharedState n k)
isOurs Address
addr SharedState n k
st = (Maybe (Index 'Soft 'ScriptK) -> Maybe (NonEmpty DerivationIndex))
-> (Maybe (Index 'Soft 'ScriptK), SharedState n k)
-> (Maybe (NonEmpty DerivationIndex), SharedState n k)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((Index 'Soft 'ScriptK -> NonEmpty DerivationIndex)
-> Maybe (Index 'Soft 'ScriptK) -> Maybe (NonEmpty DerivationIndex)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SharedState n k
-> Index 'Soft 'RoleK
-> Index 'Soft 'ScriptK
-> NonEmpty DerivationIndex
forall (n :: NetworkDiscriminant) (key :: Depth -> * -> *).
SharedState n key
-> Index 'Soft 'RoleK
-> Index 'Soft 'ScriptK
-> NonEmpty DerivationIndex
decoratePath SharedState n k
st Index 'Soft 'RoleK
utxoExternal)) (Address
-> SharedState n k
-> (Maybe (Index 'Soft 'ScriptK), SharedState n k)
forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
SupportsDiscovery n k =>
Address
-> SharedState n k
-> (Maybe (Index 'Soft 'ScriptK), SharedState n k)
isShared Address
addr SharedState n k
st)

-- | Decorate an index with the derivation prefix corresponding to the state.
decoratePath
    :: SharedState n key
    -> Index 'Soft 'RoleK
    -> Index 'Soft 'ScriptK
    -> NE.NonEmpty DerivationIndex
decoratePath :: SharedState n key
-> Index 'Soft 'RoleK
-> Index 'Soft 'ScriptK
-> NonEmpty DerivationIndex
decoratePath SharedState n key
st Index 'Soft 'RoleK
role' Index 'Soft 'ScriptK
ix = [DerivationIndex] -> NonEmpty DerivationIndex
forall a. [a] -> NonEmpty a
NE.fromList
    [ Word32 -> DerivationIndex
DerivationIndex (Word32 -> DerivationIndex) -> Word32 -> DerivationIndex
forall a b. (a -> b) -> a -> b
$ Index 'Hardened 'PurposeK -> Word32
forall (derivationType :: DerivationType) (level :: Depth).
Index derivationType level -> Word32
getIndex Index 'Hardened 'PurposeK
purpose
    , Word32 -> DerivationIndex
DerivationIndex (Word32 -> DerivationIndex) -> Word32 -> DerivationIndex
forall a b. (a -> b) -> a -> b
$ Index 'Hardened 'CoinTypeK -> Word32
forall (derivationType :: DerivationType) (level :: Depth).
Index derivationType level -> Word32
getIndex Index 'Hardened 'CoinTypeK
coinType
    , Word32 -> DerivationIndex
DerivationIndex (Word32 -> DerivationIndex) -> Word32 -> DerivationIndex
forall a b. (a -> b) -> a -> b
$ Index 'Hardened 'AccountK -> Word32
forall (derivationType :: DerivationType) (level :: Depth).
Index derivationType level -> Word32
getIndex Index 'Hardened 'AccountK
accIx
    , Word32 -> DerivationIndex
DerivationIndex (Word32 -> DerivationIndex) -> Word32 -> DerivationIndex
forall a b. (a -> b) -> a -> b
$ Index 'Soft 'RoleK -> Word32
forall (derivationType :: DerivationType) (level :: Depth).
Index derivationType level -> Word32
getIndex Index 'Soft 'RoleK
role'
    , Word32 -> DerivationIndex
DerivationIndex (Word32 -> DerivationIndex) -> Word32 -> DerivationIndex
forall a b. (a -> b) -> a -> b
$ Index 'Soft 'ScriptK -> Word32
forall (derivationType :: DerivationType) (level :: Depth).
Index derivationType level -> Word32
getIndex Index 'Soft 'ScriptK
ix
    ]
  where
    DerivationPrefix (Index 'Hardened 'PurposeK
purpose, Index 'Hardened 'CoinTypeK
coinType, Index 'Hardened 'AccountK
accIx) = SharedState n key -> DerivationPrefix
forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
SharedState n k -> DerivationPrefix
derivationPrefix SharedState n key
st

instance IsOurs (SharedState n k) RewardAccount where
    isOurs :: RewardAccount
-> SharedState n k
-> (Maybe (NonEmpty DerivationIndex), SharedState n k)
isOurs RewardAccount
_account SharedState n k
st = (Maybe (NonEmpty DerivationIndex)
forall a. Maybe a
Nothing, SharedState n k
st)

instance GetAccount (SharedState n k) k where
    getAccount :: SharedState n k -> k 'AccountK XPub
getAccount = SharedState n k -> k 'AccountK XPub
forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
SharedState n k -> k 'AccountK XPub
accountXPub

instance SupportsDiscovery n k => CompareDiscovery (SharedState n k) where
    compareDiscovery :: SharedState n k -> Address -> Address -> Ordering
compareDiscovery SharedState n k
st Address
a1 Address
a2 = case SharedState n k -> Readiness (SharedAddressPools k)
forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
SharedState n k -> Readiness (SharedAddressPools k)
ready SharedState n k
st of
        Readiness (SharedAddressPools k)
Pending ->
            String -> Ordering
forall a. HasCallStack => String -> a
error String
"comparing addresses in pending shared state does not make sense"
        Active SharedAddressPools k
pools ->
            case (Address -> SharedAddressPools k -> Maybe (Index 'Soft 'ScriptK)
ix Address
a1 SharedAddressPools k
pools, Address -> SharedAddressPools k -> Maybe (Index 'Soft 'ScriptK)
ix Address
a2 SharedAddressPools k
pools) of
                (Maybe (Index 'Soft 'ScriptK)
Nothing, Maybe (Index 'Soft 'ScriptK)
Nothing) -> Ordering
EQ
                (Maybe (Index 'Soft 'ScriptK)
Nothing, Just Index 'Soft 'ScriptK
_)  -> Ordering
GT
                (Just Index 'Soft 'ScriptK
_, Maybe (Index 'Soft 'ScriptK)
Nothing)  -> Ordering
LT
                (Just Index 'Soft 'ScriptK
i1, Just Index 'Soft 'ScriptK
i2) -> Index 'Soft 'ScriptK -> Index 'Soft 'ScriptK -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Index 'Soft 'ScriptK
i1 Index 'Soft 'ScriptK
i2
      where
        ix :: Address -> SharedAddressPools k -> Maybe (Index 'Soft 'ScriptK)
        ix :: Address -> SharedAddressPools k -> Maybe (Index 'Soft 'ScriptK)
ix Address
a (SharedAddressPools SharedAddressPool 'UtxoExternal k
extPool SharedAddressPool 'UtxoInternal k
intPool PendingIxs 'ScriptK
_) =
            case Address
-> Either
     (ErrMkKeyFingerprint k Address) (KeyFingerprint "payment" k)
forall (key :: Depth -> * -> *) from.
MkKeyFingerprint key from =>
from
-> Either
     (ErrMkKeyFingerprint key from) (KeyFingerprint "payment" key)
paymentKeyFingerprint Address
a of
                Left ErrMkKeyFingerprint k Address
_ -> Maybe (Index 'Soft 'ScriptK)
forall a. Maybe a
Nothing
                Right KeyFingerprint "payment" k
addr ->
                    KeyFingerprint "payment" k
-> Pool (KeyFingerprint "payment" k) (Index 'Soft 'ScriptK)
-> Maybe (Index 'Soft 'ScriptK)
forall addr ix. Ord addr => addr -> Pool addr ix -> Maybe ix
AddressPool.lookup KeyFingerprint "payment" k
addr (SharedAddressPool 'UtxoExternal k
-> Pool (KeyFingerprint "payment" k) (Index 'Soft 'ScriptK)
forall (c :: Role) (key :: Depth -> * -> *).
SharedAddressPool c key
-> Pool (KeyFingerprint "payment" key) (Index 'Soft 'ScriptK)
getPool SharedAddressPool 'UtxoExternal k
extPool) Maybe (Index 'Soft 'ScriptK)
-> Maybe (Index 'Soft 'ScriptK) -> Maybe (Index 'Soft 'ScriptK)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
                    KeyFingerprint "payment" k
-> Pool (KeyFingerprint "payment" k) (Index 'Soft 'ScriptK)
-> Maybe (Index 'Soft 'ScriptK)
forall addr ix. Ord addr => addr -> Pool addr ix -> Maybe ix
AddressPool.lookup KeyFingerprint "payment" k
addr (SharedAddressPool 'UtxoInternal k
-> Pool (KeyFingerprint "payment" k) (Index 'Soft 'ScriptK)
forall (c :: Role) (key :: Depth -> * -> *).
SharedAddressPool c key
-> Pool (KeyFingerprint "payment" key) (Index 'Soft 'ScriptK)
getPool SharedAddressPool 'UtxoInternal k
intPool)

instance Typeable n => KnownAddresses (SharedState n k) where
    knownAddresses :: SharedState n k
-> [(Address, AddressState, NonEmpty DerivationIndex)]
knownAddresses SharedState n k
st = case SharedState n k -> Readiness (SharedAddressPools k)
forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
SharedState n k -> Readiness (SharedAddressPools k)
ready SharedState n k
st of
        Readiness (SharedAddressPools k)
Pending -> []
        Active (SharedAddressPools SharedAddressPool 'UtxoExternal k
extPool SharedAddressPool 'UtxoInternal k
intPool PendingIxs 'ScriptK
ixs) ->
            SharedAddressPool 'UtxoExternal k
-> [(Address, AddressState, NonEmpty DerivationIndex)]
nonChangeAddresses SharedAddressPool 'UtxoExternal k
extPool [(Address, AddressState, NonEmpty DerivationIndex)]
-> [(Address, AddressState, NonEmpty DerivationIndex)]
-> [(Address, AddressState, NonEmpty DerivationIndex)]
forall a. Semigroup a => a -> a -> a
<>
            SharedAddressPool 'UtxoInternal k
-> [(Address, AddressState, NonEmpty DerivationIndex)]
usedChangeAddresses SharedAddressPool 'UtxoInternal k
intPool [(Address, AddressState, NonEmpty DerivationIndex)]
-> [(Address, AddressState, NonEmpty DerivationIndex)]
-> [(Address, AddressState, NonEmpty DerivationIndex)]
forall a. Semigroup a => a -> a -> a
<>
            SharedAddressPool 'UtxoInternal k
-> [Index 'Soft 'ScriptK]
-> [(Address, AddressState, NonEmpty DerivationIndex)]
pendingChangeAddresses SharedAddressPool 'UtxoInternal k
intPool (PendingIxs 'ScriptK -> [Index 'Soft 'ScriptK]
forall (k :: Depth). PendingIxs k -> [Index 'Soft k]
pendingIxsToList PendingIxs 'ScriptK
ixs)
      where
        nonChangeAddresses :: SharedAddressPool 'UtxoExternal k
-> [(Address, AddressState, NonEmpty DerivationIndex)]
nonChangeAddresses SharedAddressPool 'UtxoExternal k
extPool =
            ((KeyFingerprint "payment" k, (Index 'Soft 'ScriptK, AddressState))
 -> (Address, AddressState, NonEmpty DerivationIndex))
-> [(KeyFingerprint "payment" k,
     (Index 'Soft 'ScriptK, AddressState))]
-> [(Address, AddressState, NonEmpty DerivationIndex)]
forall a b. (a -> b) -> [a] -> [b]
map (Index 'Soft 'RoleK
-> (KeyFingerprint "payment" k,
    (Index 'Soft 'ScriptK, AddressState))
-> (Address, AddressState, NonEmpty DerivationIndex)
swivel Index 'Soft 'RoleK
utxoExternal) ([(KeyFingerprint "payment" k,
   (Index 'Soft 'ScriptK, AddressState))]
 -> [(Address, AddressState, NonEmpty DerivationIndex)])
-> [(KeyFingerprint "payment" k,
     (Index 'Soft 'ScriptK, AddressState))]
-> [(Address, AddressState, NonEmpty DerivationIndex)]
forall a b. (a -> b) -> a -> b
$ ((KeyFingerprint "payment" k, (Index 'Soft 'ScriptK, AddressState))
 -> Index 'Soft 'ScriptK)
-> [(KeyFingerprint "payment" k,
     (Index 'Soft 'ScriptK, AddressState))]
-> [(KeyFingerprint "payment" k,
     (Index 'Soft 'ScriptK, AddressState))]
forall b a. Ord b => (a -> b) -> [a] -> [a]
L.sortOn (KeyFingerprint "payment" k, (Index 'Soft 'ScriptK, AddressState))
-> Index 'Soft 'ScriptK
forall a a b. (a, (a, b)) -> a
idx ([(KeyFingerprint "payment" k,
   (Index 'Soft 'ScriptK, AddressState))]
 -> [(KeyFingerprint "payment" k,
      (Index 'Soft 'ScriptK, AddressState))])
-> [(KeyFingerprint "payment" k,
     (Index 'Soft 'ScriptK, AddressState))]
-> [(KeyFingerprint "payment" k,
     (Index 'Soft 'ScriptK, AddressState))]
forall a b. (a -> b) -> a -> b
$ Map
  (KeyFingerprint "payment" k) (Index 'Soft 'ScriptK, AddressState)
-> [(KeyFingerprint "payment" k,
     (Index 'Soft 'ScriptK, AddressState))]
forall k a. Map k a -> [(k, a)]
Map.toList (Map
   (KeyFingerprint "payment" k) (Index 'Soft 'ScriptK, AddressState)
 -> [(KeyFingerprint "payment" k,
      (Index 'Soft 'ScriptK, AddressState))])
-> Map
     (KeyFingerprint "payment" k) (Index 'Soft 'ScriptK, AddressState)
-> [(KeyFingerprint "payment" k,
     (Index 'Soft 'ScriptK, AddressState))]
forall a b. (a -> b) -> a -> b
$
            Pool (KeyFingerprint "payment" k) (Index 'Soft 'ScriptK)
-> Map
     (KeyFingerprint "payment" k) (Index 'Soft 'ScriptK, AddressState)
forall addr ix. Pool addr ix -> Map addr (ix, AddressState)
AddressPool.addresses (SharedAddressPool 'UtxoExternal k
-> Pool (KeyFingerprint "payment" k) (Index 'Soft 'ScriptK)
forall (c :: Role) (key :: Depth -> * -> *).
SharedAddressPool c key
-> Pool (KeyFingerprint "payment" key) (Index 'Soft 'ScriptK)
getPool SharedAddressPool 'UtxoExternal k
extPool)

        idx :: (a, (a, b)) -> a
idx (a
_,(a
ix,b
_)) = a
ix

        swivel :: Index 'Soft 'RoleK
-> (KeyFingerprint "payment" k,
    (Index 'Soft 'ScriptK, AddressState))
-> (Address, AddressState, NonEmpty DerivationIndex)
swivel Index 'Soft 'RoleK
role' (KeyFingerprint "payment" k
k,(Index 'Soft 'ScriptK
ix,AddressState
s)) =
            (KeyFingerprint "payment" k -> Address
forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
Typeable n =>
KeyFingerprint "payment" k -> Address
liftPaymentAddress @n KeyFingerprint "payment" k
k, AddressState
s, SharedState n k
-> Index 'Soft 'RoleK
-> Index 'Soft 'ScriptK
-> NonEmpty DerivationIndex
forall (n :: NetworkDiscriminant) (key :: Depth -> * -> *).
SharedState n key
-> Index 'Soft 'RoleK
-> Index 'Soft 'ScriptK
-> NonEmpty DerivationIndex
decoratePath SharedState n k
st Index 'Soft 'RoleK
role' Index 'Soft 'ScriptK
ix)

        changeAddresses :: SharedAddressPool 'UtxoInternal k
-> [(Address, AddressState, NonEmpty DerivationIndex)]
changeAddresses SharedAddressPool 'UtxoInternal k
intPool =
            ((KeyFingerprint "payment" k, (Index 'Soft 'ScriptK, AddressState))
 -> (Address, AddressState, NonEmpty DerivationIndex))
-> [(KeyFingerprint "payment" k,
     (Index 'Soft 'ScriptK, AddressState))]
-> [(Address, AddressState, NonEmpty DerivationIndex)]
forall a b. (a -> b) -> [a] -> [b]
map (Index 'Soft 'RoleK
-> (KeyFingerprint "payment" k,
    (Index 'Soft 'ScriptK, AddressState))
-> (Address, AddressState, NonEmpty DerivationIndex)
swivel Index 'Soft 'RoleK
utxoInternal) ([(KeyFingerprint "payment" k,
   (Index 'Soft 'ScriptK, AddressState))]
 -> [(Address, AddressState, NonEmpty DerivationIndex)])
-> [(KeyFingerprint "payment" k,
     (Index 'Soft 'ScriptK, AddressState))]
-> [(Address, AddressState, NonEmpty DerivationIndex)]
forall a b. (a -> b) -> a -> b
$ ((KeyFingerprint "payment" k, (Index 'Soft 'ScriptK, AddressState))
 -> Index 'Soft 'ScriptK)
-> [(KeyFingerprint "payment" k,
     (Index 'Soft 'ScriptK, AddressState))]
-> [(KeyFingerprint "payment" k,
     (Index 'Soft 'ScriptK, AddressState))]
forall b a. Ord b => (a -> b) -> [a] -> [a]
L.sortOn (KeyFingerprint "payment" k, (Index 'Soft 'ScriptK, AddressState))
-> Index 'Soft 'ScriptK
forall a a b. (a, (a, b)) -> a
idx ([(KeyFingerprint "payment" k,
   (Index 'Soft 'ScriptK, AddressState))]
 -> [(KeyFingerprint "payment" k,
      (Index 'Soft 'ScriptK, AddressState))])
-> [(KeyFingerprint "payment" k,
     (Index 'Soft 'ScriptK, AddressState))]
-> [(KeyFingerprint "payment" k,
     (Index 'Soft 'ScriptK, AddressState))]
forall a b. (a -> b) -> a -> b
$ Map
  (KeyFingerprint "payment" k) (Index 'Soft 'ScriptK, AddressState)
-> [(KeyFingerprint "payment" k,
     (Index 'Soft 'ScriptK, AddressState))]
forall k a. Map k a -> [(k, a)]
Map.toList (Map
   (KeyFingerprint "payment" k) (Index 'Soft 'ScriptK, AddressState)
 -> [(KeyFingerprint "payment" k,
      (Index 'Soft 'ScriptK, AddressState))])
-> Map
     (KeyFingerprint "payment" k) (Index 'Soft 'ScriptK, AddressState)
-> [(KeyFingerprint "payment" k,
     (Index 'Soft 'ScriptK, AddressState))]
forall a b. (a -> b) -> a -> b
$
            Pool (KeyFingerprint "payment" k) (Index 'Soft 'ScriptK)
-> Map
     (KeyFingerprint "payment" k) (Index 'Soft 'ScriptK, AddressState)
forall addr ix. Pool addr ix -> Map addr (ix, AddressState)
AddressPool.addresses (SharedAddressPool 'UtxoInternal k
-> Pool (KeyFingerprint "payment" k) (Index 'Soft 'ScriptK)
forall (c :: Role) (key :: Depth -> * -> *).
SharedAddressPool c key
-> Pool (KeyFingerprint "payment" key) (Index 'Soft 'ScriptK)
getPool SharedAddressPool 'UtxoInternal k
intPool)
        usedChangeAddresses :: SharedAddressPool 'UtxoInternal k
-> [(Address, AddressState, NonEmpty DerivationIndex)]
usedChangeAddresses SharedAddressPool 'UtxoInternal k
intPool =
            ((Address, AddressState, NonEmpty DerivationIndex) -> Bool)
-> [(Address, AddressState, NonEmpty DerivationIndex)]
-> [(Address, AddressState, NonEmpty DerivationIndex)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Address
_, AddressState
status, NonEmpty DerivationIndex
_) -> AddressState
status AddressState -> AddressState -> Bool
forall a. Eq a => a -> a -> Bool
== AddressState
Used) ([(Address, AddressState, NonEmpty DerivationIndex)]
 -> [(Address, AddressState, NonEmpty DerivationIndex)])
-> [(Address, AddressState, NonEmpty DerivationIndex)]
-> [(Address, AddressState, NonEmpty DerivationIndex)]
forall a b. (a -> b) -> a -> b
$
            SharedAddressPool 'UtxoInternal k
-> [(Address, AddressState, NonEmpty DerivationIndex)]
changeAddresses SharedAddressPool 'UtxoInternal k
intPool

        -- pick as many unused change addresses as there are pending
        -- transactions. Note: the last `internalGap` addresses are all
        -- unused.
        pendingChangeAddresses :: SharedAddressPool 'UtxoInternal k
-> [Index 'Soft 'ScriptK]
-> [(Address, AddressState, NonEmpty DerivationIndex)]
pendingChangeAddresses SharedAddressPool 'UtxoInternal k
intPool [Index 'Soft 'ScriptK]
ixs =
            let internalGap :: Int
internalGap = Pool (KeyFingerprint "payment" k) (Index 'Soft 'ScriptK) -> Int
forall addr ix. Pool addr ix -> Int
AddressPool.gap (Pool (KeyFingerprint "payment" k) (Index 'Soft 'ScriptK) -> Int)
-> Pool (KeyFingerprint "payment" k) (Index 'Soft 'ScriptK) -> Int
forall a b. (a -> b) -> a -> b
$ SharedAddressPool 'UtxoInternal k
-> Pool (KeyFingerprint "payment" k) (Index 'Soft 'ScriptK)
forall (c :: Role) (key :: Depth -> * -> *).
SharedAddressPool c key
-> Pool (KeyFingerprint "payment" key) (Index 'Soft 'ScriptK)
getPool SharedAddressPool 'UtxoInternal k
intPool
                changeAddresses' :: [(Address, AddressState, NonEmpty DerivationIndex)]
changeAddresses' = SharedAddressPool 'UtxoInternal k
-> [(Address, AddressState, NonEmpty DerivationIndex)]
changeAddresses SharedAddressPool 'UtxoInternal k
intPool
                edgeChangeAddresses :: [(Address, AddressState, NonEmpty DerivationIndex)]
edgeChangeAddresses =
                    Int
-> [(Address, AddressState, NonEmpty DerivationIndex)]
-> [(Address, AddressState, NonEmpty DerivationIndex)]
forall a. Int -> [a] -> [a]
drop ([(Address, AddressState, NonEmpty DerivationIndex)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Address, AddressState, NonEmpty DerivationIndex)]
changeAddresses' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
internalGap) [(Address, AddressState, NonEmpty DerivationIndex)]
changeAddresses'
            in Int
-> [(Address, AddressState, NonEmpty DerivationIndex)]
-> [(Address, AddressState, NonEmpty DerivationIndex)]
forall a. Int -> [a] -> [a]
take ([Index 'Soft 'ScriptK] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Index 'Soft 'ScriptK]
ixs) [(Address, AddressState, NonEmpty DerivationIndex)]
edgeChangeAddresses

instance MaybeLight (SharedState n k) where
    maybeDiscover :: Maybe (LightDiscoverTxs (SharedState n k))
maybeDiscover = Maybe (LightDiscoverTxs (SharedState n k))
forall a. Maybe a
Nothing

instance GenChange (SharedState n k) where
    type ArgGenChange (SharedState n k) =
        (ScriptTemplate -> Maybe ScriptTemplate -> Index 'Soft 'ScriptK -> Address)

    genChange :: ArgGenChange (SharedState n k)
-> SharedState n k -> (Address, SharedState n k)
genChange ArgGenChange (SharedState n k)
mkAddress SharedState n k
st = case SharedState n k -> Readiness (SharedAddressPools k)
forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
SharedState n k -> Readiness (SharedAddressPools k)
ready SharedState n k
st of
        Readiness (SharedAddressPools k)
Pending ->
            String -> (Address, SharedState n k)
forall a. HasCallStack => String -> a
error String
"generating change in pending shared state does not make sense"
        Active (SharedAddressPools SharedAddressPool 'UtxoExternal k
extPool SharedAddressPool 'UtxoInternal k
intPool PendingIxs 'ScriptK
pending) ->
            let (Index 'Soft 'ScriptK
ix, PendingIxs 'ScriptK
pending') = Pool (KeyFingerprint "payment" k) (Index 'Soft 'ScriptK)
-> PendingIxs 'ScriptK
-> (Index 'Soft 'ScriptK, PendingIxs 'ScriptK)
forall (key :: Depth -> * -> *) (k :: Depth).
Pool (KeyFingerprint "payment" key) (Index 'Soft k)
-> PendingIxs k -> (Index 'Soft k, PendingIxs k)
nextChangeIndex (SharedAddressPool 'UtxoInternal k
-> Pool (KeyFingerprint "payment" k) (Index 'Soft 'ScriptK)
forall (c :: Role) (key :: Depth -> * -> *).
SharedAddressPool c key
-> Pool (KeyFingerprint "payment" key) (Index 'Soft 'ScriptK)
getPool SharedAddressPool 'UtxoInternal k
intPool) PendingIxs 'ScriptK
pending
                addr :: Address
addr = ArgGenChange (SharedState n k)
ScriptTemplate
-> Maybe ScriptTemplate -> Index 'Soft 'ScriptK -> Address
mkAddress (SharedState n k -> ScriptTemplate
forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
SharedState n k -> ScriptTemplate
paymentTemplate SharedState n k
st) (SharedState n k -> Maybe ScriptTemplate
forall (n :: NetworkDiscriminant) (k :: Depth -> * -> *).
SharedState n k -> Maybe ScriptTemplate
delegationTemplate SharedState n k
st) Index 'Soft 'ScriptK
ix
            in (Address
addr, SharedState n k
st{ ready :: Readiness (SharedAddressPools k)
ready = SharedAddressPools k -> Readiness (SharedAddressPools k)
forall a. a -> Readiness a
Active (SharedAddressPool 'UtxoExternal k
-> SharedAddressPool 'UtxoInternal k
-> PendingIxs 'ScriptK
-> SharedAddressPools k
forall (key :: Depth -> * -> *).
SharedAddressPool 'UtxoExternal key
-> SharedAddressPool 'UtxoInternal key
-> PendingIxs 'ScriptK
-> SharedAddressPools key
SharedAddressPools SharedAddressPool 'UtxoExternal k
extPool SharedAddressPool 'UtxoInternal k
intPool PendingIxs 'ScriptK
pending') })

{-------------------------------------------------------------------------------
    Address utilities
    Payment and Delegation parts
-------------------------------------------------------------------------------}

data CredentialType = Payment | Delegation
    deriving (CredentialType -> CredentialType -> Bool
(CredentialType -> CredentialType -> Bool)
-> (CredentialType -> CredentialType -> Bool) -> Eq CredentialType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CredentialType -> CredentialType -> Bool
$c/= :: CredentialType -> CredentialType -> Bool
== :: CredentialType -> CredentialType -> Bool
$c== :: CredentialType -> CredentialType -> Bool
Eq, Int -> CredentialType -> ShowS
[CredentialType] -> ShowS
CredentialType -> String
(Int -> CredentialType -> ShowS)
-> (CredentialType -> String)
-> ([CredentialType] -> ShowS)
-> Show CredentialType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CredentialType] -> ShowS
$cshowList :: [CredentialType] -> ShowS
show :: CredentialType -> String
$cshow :: CredentialType -> String
showsPrec :: Int -> CredentialType -> ShowS
$cshowsPrec :: Int -> CredentialType -> ShowS
Show, (forall x. CredentialType -> Rep CredentialType x)
-> (forall x. Rep CredentialType x -> CredentialType)
-> Generic CredentialType
forall x. Rep CredentialType x -> CredentialType
forall x. CredentialType -> Rep CredentialType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CredentialType x -> CredentialType
$cfrom :: forall x. CredentialType -> Rep CredentialType x
Generic)
    deriving anyclass CredentialType -> ()
(CredentialType -> ()) -> NFData CredentialType
forall a. (a -> ()) -> NFData a
rnf :: CredentialType -> ()
$crnf :: CredentialType -> ()
NFData

instance ToText CredentialType where
    toText :: CredentialType -> Text
toText CredentialType
Payment = Text
"payment"
    toText CredentialType
Delegation = Text
"delegation"

instance FromText CredentialType where
    fromText :: Text -> Either TextDecodingError CredentialType
fromText = \case
        Text
"payment" -> CredentialType -> Either TextDecodingError CredentialType
forall a b. b -> Either a b
Right CredentialType
Payment
        Text
"delegation" -> CredentialType -> Either TextDecodingError CredentialType
forall a b. b -> Either a b
Right CredentialType
Delegation
        Text
_ -> TextDecodingError -> Either TextDecodingError CredentialType
forall a b. a -> Either a b
Left (TextDecodingError -> Either TextDecodingError CredentialType)
-> TextDecodingError -> Either TextDecodingError CredentialType
forall a b. (a -> b) -> a -> b
$ String -> TextDecodingError
TextDecodingError (String -> TextDecodingError) -> String -> TextDecodingError
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords
            [ String
"Invalid credential type: expecting only following values:"
            , String
"'payment', 'delegation'."
            ]

liftPaymentAddress
    :: forall (n :: NetworkDiscriminant) (k :: Depth -> Type -> Type).
       Typeable n
    => KeyFingerprint "payment" k
    -> Address
liftPaymentAddress :: KeyFingerprint "payment" k -> Address
liftPaymentAddress (KeyFingerprint ByteString
fingerprint) =
    ByteString -> Address
Address (ByteString -> Address) -> ByteString -> Address
forall a b. (a -> b) -> a -> b
$ Address -> ByteString
CA.unAddress (Address -> ByteString) -> Address -> ByteString
forall a b. (a -> b) -> a -> b
$
    NetworkDiscriminant Shelley -> Credential 'PaymentK -> Address
paymentAddress (Typeable n => NetworkTag
forall (n :: NetworkDiscriminant). Typeable n => NetworkTag
toNetworkTag @n)
    (ScriptHash -> Credential 'PaymentK
PaymentFromScript (ByteString -> ScriptHash
ScriptHash ByteString
fingerprint))

liftDelegationAddress
    :: forall (n :: NetworkDiscriminant) (k :: Depth -> Type -> Type).
       Typeable n
    => Index 'Soft 'ScriptK
    -> ScriptTemplate
    -> KeyFingerprint "payment" k
    -> Address
liftDelegationAddress :: Index 'Soft 'ScriptK
-> ScriptTemplate -> KeyFingerprint "payment" k -> Address
liftDelegationAddress Index 'Soft 'ScriptK
ix ScriptTemplate
dTemplate (KeyFingerprint ByteString
fingerprint) =
    ByteString -> Address
Address (ByteString -> Address) -> ByteString -> Address
forall a b. (a -> b) -> a -> b
$ Address -> ByteString
CA.unAddress (Address -> ByteString) -> Address -> ByteString
forall a b. (a -> b) -> a -> b
$
    NetworkDiscriminant Shelley
-> Credential 'PaymentK -> Credential 'DelegationK -> Address
delegationAddress (Typeable n => NetworkTag
forall (n :: NetworkDiscriminant). Typeable n => NetworkTag
toNetworkTag @n)
    (ScriptHash -> Credential 'PaymentK
PaymentFromScript (ByteString -> ScriptHash
ScriptHash ByteString
fingerprint))
    (Script KeyHash -> Credential 'DelegationK
delegationCredential Script KeyHash
dScript)
  where
    delegationCredential :: Script KeyHash -> Credential 'DelegationK
delegationCredential = ScriptHash -> Credential 'DelegationK
DelegationFromScript (ScriptHash -> Credential 'DelegationK)
-> (Script KeyHash -> ScriptHash)
-> Script KeyHash
-> Credential 'DelegationK
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Script KeyHash -> ScriptHash
toScriptHash
    dScript :: Script KeyHash
dScript =
        Role -> ScriptTemplate -> Index 'Soft 'ScriptK -> Script KeyHash
replaceCosignersWithVerKeys Role
CA.Stake ScriptTemplate
dTemplate Index 'Soft 'ScriptK
ix

toSharedWalletId
    :: (WalletKey k, k ~ SharedKey)
    => k 'AccountK XPub
    -> ScriptTemplate
    -> Maybe ScriptTemplate
    -> Digest Blake2b_160
toSharedWalletId :: k 'AccountK XPub
-> ScriptTemplate -> Maybe ScriptTemplate -> Digest Blake2b_160
toSharedWalletId k 'AccountK XPub
accXPub ScriptTemplate
pTemplate Maybe ScriptTemplate
dTemplateM =
    ByteString -> Digest Blake2b_160
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
hash (ByteString -> Digest Blake2b_160)
-> ByteString -> Digest Blake2b_160
forall a b. (a -> b) -> a -> b
$
    (XPub -> ByteString
unXPub (XPub -> ByteString)
-> (k 'AccountK XPub -> XPub) -> k 'AccountK XPub -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k 'AccountK XPub -> XPub
forall (key :: Depth -> * -> *) (depth :: Depth) raw.
WalletKey key =>
key depth raw -> raw
getRawKey (k 'AccountK XPub -> ByteString) -> k 'AccountK XPub -> ByteString
forall a b. (a -> b) -> a -> b
$ k 'AccountK XPub
accXPub) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>
    ScriptTemplate -> ByteString
serializeScriptTemplate ScriptTemplate
pTemplate ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>
    ByteString
-> (ScriptTemplate -> ByteString)
-> Maybe ScriptTemplate
-> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
forall a. Monoid a => a
mempty ScriptTemplate -> ByteString
serializeScriptTemplate Maybe ScriptTemplate
dTemplateM
  where
    serializeScriptTemplate :: ScriptTemplate -> ByteString
serializeScriptTemplate (ScriptTemplate Map Cosigner XPub
_ Script Cosigner
script) =
        Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Script Cosigner -> Text
forall a. Show a => Script a -> Text
scriptToText Script Cosigner
script