{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}

-- |
-- Copyright: © 2018-2020 IOHK
-- License: Apache-2.0
--
-- This module contains types for address discovery. The two address discovery
-- schemes implemented are:
--
--  * "Cardano.Wallet.Primitive.AddressDiscovery.Sequential"
--  * "Cardano.Wallet.Primitive.AddressDiscovery.Random"

module Cardano.Wallet.Primitive.AddressDiscovery
    (
    -- * Abstractions
      IsOurs(..)
    , IsOwned(..)
    , GenChange(..)
    , CompareDiscovery(..)
    , KnownAddresses(..)
    , GetPurpose (..)
    , GetAccount (..)
    , coinTypeAda
    , MaybeLight (..)
    , DiscoverTxs (..)

    , PendingIxs
    , emptyPendingIxs
    , pendingIxsToList
    , pendingIxsFromList
    , nextChangeIndex
    , updatePendingIxs
    ) where

import Prelude

import Cardano.Crypto.Wallet
    ( XPrv, XPub )
import Cardano.Wallet.Primitive.AddressDerivation
    ( Depth (..)
    , DerivationIndex (..)
    , DerivationType (..)
    , Index (..)
    , KeyFingerprint (..)
    , RewardAccount
    )
import Cardano.Wallet.Primitive.BlockSummary
    ( ChainEvents )
import Cardano.Wallet.Primitive.Passphrase
    ( Passphrase (..) )
import Cardano.Wallet.Primitive.Types.Address
    ( Address (..), AddressState (..) )
import Cardano.Wallet.Util
    ( invariant )
import Control.DeepSeq
    ( NFData )
import Data.Kind
    ( Type )
import Data.List.NonEmpty
    ( NonEmpty )
import GHC.Generics
    ( Generic )

import qualified Cardano.Wallet.Address.Pool as AddressPool
import qualified Data.List as L

-- | Checks whether or not a given entity belongs to us.
--
-- This abstraction exists to give us the ability to keep the wallet business
-- logic agnostic to the address derivation and discovery mechanisms.
--
-- This is needed because two different address schemes lives on Cardano:
--
--   - A hierarchical random scheme:
--      rather 'custom' made, with several flaws; this is the original and now
--      legacy address scheme.
--
--   - A hierarchical sequential scheme:
--      a new scheme based on the BIP-0044 specification, which is better suited
--      for our present needs.
--
-- In practice, we will need a wallet that can support both, even if not at the
-- same time, and this little abstraction can buy us this without introducing
-- too much overhead.
class IsOurs s entity where
    isOurs
        :: entity
        -> s
        -> (Maybe (NonEmpty DerivationIndex), s)
        -- ^ Returns derivation path if the entity is ours, otherwise Nothing.

-- | More powerful than 'isOurs', this abstractions offer the underlying state
-- the ability to find / compute the address private key corresponding to a
-- given known address.
--
-- Requiring 'IsOwned' as a constraint supposed that there is a way to recover
-- the root private key of a particular wallet. This isn't true for externally
-- owned wallet which would delegate its key management to a third party (like
-- a hardware Ledger or Trezor).
class IsOurs s Address => IsOwned s key where
    isOwned
        :: s
        -> (key 'RootK XPrv, Passphrase "encryption")
        -> Address
        -> Maybe (key 'AddressK XPrv, Passphrase "encryption")
        -- ^ Derive the private key corresponding to an address. Careful, this
        -- operation can be costly. Note that the state is discarded from this
        -- function as we do not intend to discover any addresses from this
        -- operation; This is merely a lookup from known addresses.

-- | Abstracting over change address generation. In theory, this is only needed
-- for sending transactions on a wallet following a particular scheme. This
-- abstractions allows for defining an heuristic to pick new change address. For
-- instance, in BIP-44, change addresses belong to a particular change chain
-- (also called "Internal Chain").
class GenChange s where
    type ArgGenChange s :: Type
    genChange
        :: ArgGenChange s
        -> s
        -> (Address, s)
        -- ^ Generate a new change address for the given scheme. The rules for
        -- generating a new change address depends on the underlying scheme.

-- | Ordering addresses by discovery date.
--
-- If `a1` has been discovered before `a2`, then the following equation holds:
--
-- @
-- compareDiscovery s a1 a2 == LT
-- @
--
-- If `a1` has been discovered after `a2`, then the following equation holds:
--
-- @
-- compareDiscovery s a1 a2 == GT
-- @
--
-- Note that, if an address isn't known it is considered not discovered and
-- therefore, is always _greater than_ any known address.
class CompareDiscovery s where
    compareDiscovery
        :: s
        -> Address
        -> Address
        -> Ordering

-- | Extract the list of all known addresses.
--
-- NOTE: Change addresses aren't considered "known" until they've been used. The
-- rationale is that, we don't want users or consumers of the wallet to be using
-- change addresses prematurely.
class KnownAddresses s where
    knownAddresses
        :: s
        -> [(Address, AddressState, NonEmpty DerivationIndex)]

-- | One master node (seed) can be used for unlimited number of independent
-- cryptocoins such as Bitcoin, Litecoin or Namecoin. However, sharing the
-- same space for various cryptocoins has some disadvantages.
--
-- This level creates a separate subtree for every cryptocoin, avoiding reusing
-- addresses across cryptocoins and improving privacy issues.
--
-- Coin type is a constant, set for each cryptocoin. For Cardano this constant
-- is set to 1815' (or 0x80000717). 1815 is the birthyear of our beloved Ada
-- Lovelace.
--
-- Hardened derivation is used at this level.
coinTypeAda :: Index 'Hardened 'CoinTypeK
coinTypeAda :: Index 'Hardened 'CoinTypeK
coinTypeAda = Int -> Index 'Hardened 'CoinTypeK
forall a. Enum a => Int -> a
toEnum Int
0x80000717

-- It is used for getting purpose for a given key.
class GetPurpose (key :: Depth -> Type -> Type)  where
    getPurpose :: Index 'Hardened 'PurposeK

-- It is used for getting account public key for a given state.
class GetAccount s (key :: Depth -> Type -> Type) | s -> key  where
    getAccount :: s -> key 'AccountK XPub

-- | Checks whether the address discovery state @s@ works in light-mode
-- and returns a procedure for discovering addresses
-- if that is indeed the case.
class MaybeLight s where
    maybeDiscover :: Maybe (LightDiscoverTxs s)

type LightDiscoverTxs s =
    DiscoverTxs (Either Address RewardAccount) ChainEvents s

-- | Function that discovers transactions based on an address.
newtype DiscoverTxs addr txs s = DiscoverTxs
    { DiscoverTxs addr txs s
-> forall (m :: * -> *).
   Monad m =>
   (addr -> m txs) -> s -> m (txs, s)
discoverTxs
        :: forall m. Monad m
        => (addr -> m txs) -> s -> m (txs, s)
    }

{-------------------------------------------------------------------------------
                            Pending Change Indexes
-------------------------------------------------------------------------------}

-- | An ordered set of pending indexes. This keep track of indexes used
newtype PendingIxs k = PendingIxs
    { PendingIxs k -> [Index 'Soft k]
pendingIxsToList :: [Index 'Soft k] }
    deriving stock ((forall x. PendingIxs k -> Rep (PendingIxs k) x)
-> (forall x. Rep (PendingIxs k) x -> PendingIxs k)
-> Generic (PendingIxs k)
forall x. Rep (PendingIxs k) x -> PendingIxs k
forall x. PendingIxs k -> Rep (PendingIxs k) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (k :: Depth) x. Rep (PendingIxs k) x -> PendingIxs k
forall (k :: Depth) x. PendingIxs k -> Rep (PendingIxs k) x
$cto :: forall (k :: Depth) x. Rep (PendingIxs k) x -> PendingIxs k
$cfrom :: forall (k :: Depth) x. PendingIxs k -> Rep (PendingIxs k) x
Generic, Int -> PendingIxs k -> ShowS
[PendingIxs k] -> ShowS
PendingIxs k -> String
(Int -> PendingIxs k -> ShowS)
-> (PendingIxs k -> String)
-> ([PendingIxs k] -> ShowS)
-> Show (PendingIxs k)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (k :: Depth). Int -> PendingIxs k -> ShowS
forall (k :: Depth). [PendingIxs k] -> ShowS
forall (k :: Depth). PendingIxs k -> String
showList :: [PendingIxs k] -> ShowS
$cshowList :: forall (k :: Depth). [PendingIxs k] -> ShowS
show :: PendingIxs k -> String
$cshow :: forall (k :: Depth). PendingIxs k -> String
showsPrec :: Int -> PendingIxs k -> ShowS
$cshowsPrec :: forall (k :: Depth). Int -> PendingIxs k -> ShowS
Show, PendingIxs k -> PendingIxs k -> Bool
(PendingIxs k -> PendingIxs k -> Bool)
-> (PendingIxs k -> PendingIxs k -> Bool) -> Eq (PendingIxs k)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (k :: Depth). PendingIxs k -> PendingIxs k -> Bool
/= :: PendingIxs k -> PendingIxs k -> Bool
$c/= :: forall (k :: Depth). PendingIxs k -> PendingIxs k -> Bool
== :: PendingIxs k -> PendingIxs k -> Bool
$c== :: forall (k :: Depth). PendingIxs k -> PendingIxs k -> Bool
Eq)

instance NFData (PendingIxs k)

-- | An empty pending set of change indexes.
--
-- NOTE: We do not define a 'Monoid' instance here because there's no rational
-- of combining two pending sets.
emptyPendingIxs :: PendingIxs k
emptyPendingIxs :: PendingIxs k
emptyPendingIxs = [Index 'Soft k] -> PendingIxs k
forall (k :: Depth). [Index 'Soft k] -> PendingIxs k
PendingIxs [Index 'Soft k]
forall a. Monoid a => a
mempty

-- | Construct a 'PendingIxs' from a list, ensuring that it is a set of indexes
-- in descending order.
pendingIxsFromList :: [Index 'Soft k] -> PendingIxs k
pendingIxsFromList :: [Index 'Soft k] -> PendingIxs k
pendingIxsFromList = [Index 'Soft k] -> PendingIxs k
forall (k :: Depth). [Index 'Soft k] -> PendingIxs k
PendingIxs ([Index 'Soft k] -> PendingIxs k)
-> ([Index 'Soft k] -> [Index 'Soft k])
-> [Index 'Soft k]
-> PendingIxs k
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Index 'Soft k] -> [Index 'Soft k]
forall a. [a] -> [a]
reverse ([Index 'Soft k] -> [Index 'Soft k])
-> ([Index 'Soft k] -> [Index 'Soft k])
-> [Index 'Soft k]
-> [Index 'Soft k]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Index 'Soft k] -> Index 'Soft k)
-> [[Index 'Soft k]] -> [Index 'Soft k]
forall a b. (a -> b) -> [a] -> [b]
map [Index 'Soft k] -> Index 'Soft k
forall a. [a] -> a
head ([[Index 'Soft k]] -> [Index 'Soft k])
-> ([Index 'Soft k] -> [[Index 'Soft k]])
-> [Index 'Soft k]
-> [Index 'Soft k]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Index 'Soft k] -> [[Index 'Soft k]]
forall a. Eq a => [a] -> [[a]]
L.group ([Index 'Soft k] -> [[Index 'Soft k]])
-> ([Index 'Soft k] -> [Index 'Soft k])
-> [Index 'Soft k]
-> [[Index 'Soft k]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Index 'Soft k] -> [Index 'Soft k]
forall a. Ord a => [a] -> [a]
L.sort

-- | Get the next change index; If every available indexes have already been
-- taken, we'll rotate the pending set and re-use already provided indexes.
nextChangeIndex
    :: forall (key :: Depth -> Type -> Type) k.
       AddressPool.Pool (KeyFingerprint "payment" key) (Index 'Soft k)
    -> PendingIxs k
    -> (Index 'Soft k, PendingIxs k)
nextChangeIndex :: Pool (KeyFingerprint "payment" key) (Index 'Soft k)
-> PendingIxs k -> (Index 'Soft k, PendingIxs k)
nextChangeIndex Pool (KeyFingerprint "payment" key) (Index 'Soft k)
pool (PendingIxs [Index 'Soft k]
ixs) =
    let
        poolLen :: Int
poolLen = Pool (KeyFingerprint "payment" key) (Index 'Soft k) -> Int
forall addr ix. Pool addr ix -> Int
AddressPool.size  Pool (KeyFingerprint "payment" key) (Index 'Soft k)
pool
        (Index 'Soft k
firstUnused, Index 'Soft k
lastUnused) =
            ( Int -> Index 'Soft k
forall a. Enum a => Int -> a
toEnum (Int -> Index 'Soft k) -> Int -> Index 'Soft k
forall a b. (a -> b) -> a -> b
$ Int
poolLen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Pool (KeyFingerprint "payment" key) (Index 'Soft k) -> Int
forall addr ix. Pool addr ix -> Int
AddressPool.gap Pool (KeyFingerprint "payment" key) (Index 'Soft k)
pool
            , Int -> Index 'Soft k
forall a. Enum a => Int -> a
toEnum (Int -> Index 'Soft k) -> Int -> Index 'Soft k
forall a b. (a -> b) -> a -> b
$ Int
poolLen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
            )
        (Index 'Soft k
ix, PendingIxs k
ixs') = case [Index 'Soft k]
ixs of
            [] ->
                (Index 'Soft k
firstUnused, [Index 'Soft k] -> PendingIxs k
forall (k :: Depth). [Index 'Soft k] -> PendingIxs k
PendingIxs [Index 'Soft k
firstUnused])
            Index 'Soft k
h:[Index 'Soft k]
_ | [Index 'Soft k] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Index 'Soft k]
ixs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Pool (KeyFingerprint "payment" key) (Index 'Soft k) -> Int
forall addr ix. Pool addr ix -> Int
AddressPool.gap Pool (KeyFingerprint "payment" key) (Index 'Soft k)
pool ->
                (Index 'Soft k -> Index 'Soft k
forall a. Enum a => a -> a
succ Index 'Soft k
h, [Index 'Soft k] -> PendingIxs k
forall (k :: Depth). [Index 'Soft k] -> PendingIxs k
PendingIxs (Index 'Soft k -> Index 'Soft k
forall a. Enum a => a -> a
succ Index 'Soft k
hIndex 'Soft k -> [Index 'Soft k] -> [Index 'Soft k]
forall a. a -> [a] -> [a]
:[Index 'Soft k]
ixs))
            Index 'Soft k
h:[Index 'Soft k]
q ->
                (Index 'Soft k
h, [Index 'Soft k] -> PendingIxs k
forall (k :: Depth). [Index 'Soft k] -> PendingIxs k
PendingIxs ([Index 'Soft k]
q[Index 'Soft k] -> [Index 'Soft k] -> [Index 'Soft k]
forall a. [a] -> [a] -> [a]
++[Index 'Soft k
h]))
    in
        String
-> (Index 'Soft k, PendingIxs k)
-> ((Index 'Soft k, PendingIxs k) -> Bool)
-> (Index 'Soft k, PendingIxs k)
forall a. HasCallStack => String -> a -> (a -> Bool) -> a
invariant String
"index is within first unused and last unused" (Index 'Soft k
ix, PendingIxs k
ixs')
            (\(Index 'Soft k
i,PendingIxs k
_) -> Index 'Soft k
i Index 'Soft k -> Index 'Soft k -> Bool
forall a. Ord a => a -> a -> Bool
>= Index 'Soft k
firstUnused Bool -> Bool -> Bool
&& Index 'Soft k
i Index 'Soft k -> Index 'Soft k -> Bool
forall a. Ord a => a -> a -> Bool
<= Index 'Soft k
lastUnused)

-- | Update the set of pending indexes by discarding every indexes _below_ the
-- given index.
--
-- Why is that?
--
-- Because we really do care about the higher index that was last used in order
-- to know from where we can generate new indexes.
updatePendingIxs
    :: Index 'Soft k
    -> PendingIxs k
    -> PendingIxs k
updatePendingIxs :: Index 'Soft k -> PendingIxs k -> PendingIxs k
updatePendingIxs Index 'Soft k
ix (PendingIxs [Index 'Soft k]
ixs) =
    [Index 'Soft k] -> PendingIxs k
forall (k :: Depth). [Index 'Soft k] -> PendingIxs k
PendingIxs ([Index 'Soft k] -> PendingIxs k)
-> [Index 'Soft k] -> PendingIxs k
forall a b. (a -> b) -> a -> b
$ (Index 'Soft k -> Bool) -> [Index 'Soft k] -> [Index 'Soft k]
forall a. (a -> Bool) -> [a] -> [a]
L.filter (Index 'Soft k -> Index 'Soft k -> Bool
forall a. Ord a => a -> a -> Bool
> Index 'Soft k
ix) [Index 'Soft k]
ixs