{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

-- |
-- Copyright: © 2018-2021 IOHK
-- License: Apache-2.0
--
-- Definition of 'Shared' Keys.

module Cardano.Wallet.Primitive.AddressDerivation.SharedKey
    ( -- * Types
      SharedKey(..)

    , purposeCIP1854
    , constructAddressFromIx
    , toNetworkTag
    , replaceCosignersWithVerKeys
    ) where

import Prelude

import Cardano.Address.Script
    ( Cosigner, KeyHash, Script (..), ScriptTemplate (..), toScriptHash )
import Cardano.Address.Style.Shared
    ( deriveAddressPublicKey, deriveDelegationPublicKey, hashKey, liftXPub )
import Cardano.Address.Style.Shelley
    ( Credential (..), delegationAddress, paymentAddress )
import Cardano.Wallet.Primitive.AddressDerivation
    ( Depth (..)
    , DerivationType (..)
    , Index (..)
    , NetworkDiscriminant (..)
    , Role (..)
    )
import Cardano.Wallet.Primitive.Types.Address
    ( Address (..) )
import Cardano.Wallet.Util
    ( invariant )
import Control.DeepSeq
    ( NFData (..) )
import Data.Maybe
    ( fromJust, isJust )
import Data.Type.Equality
    ( (:~:) (..), testEquality )
import GHC.Generics
    ( Generic )
import Type.Reflection
    ( Typeable, typeRep )

import qualified Cardano.Address as CA
import qualified Cardano.Address.Derivation as CA
import qualified Cardano.Address.Script as CA
import qualified Cardano.Address.Style.Shelley as CA
import qualified Data.Map.Strict as Map


-- | Purpose for shared wallets is a constant set to 1854' (or 0x8000073E) following the original
-- CIP-1854 Multi-signature Wallets.
--
-- It indicates that the subtree of this node is used according to this
-- specification.
--
-- Hardened derivation is used at this level.
purposeCIP1854 :: Index 'Hardened 'PurposeK
purposeCIP1854 :: Index 'Hardened 'PurposeK
purposeCIP1854 = Int -> Index 'Hardened 'PurposeK
forall a. Enum a => Int -> a
toEnum Int
0x8000073E

-- | A cryptographic key for Shared address derivation, with phantom-types to
-- disambiguate derivation paths
--
-- @
-- let rootPrivateKey = SharedKey 'RootK XPrv
-- let accountPubKey = SharedKey 'AccountK XPub
-- let addressPubKey = SharedKey 'AddressK XPub
-- @
newtype SharedKey (depth :: Depth) key =
    SharedKey { SharedKey depth key -> key
getKey :: key }
    deriving stock ((forall x. SharedKey depth key -> Rep (SharedKey depth key) x)
-> (forall x. Rep (SharedKey depth key) x -> SharedKey depth key)
-> Generic (SharedKey depth key)
forall x. Rep (SharedKey depth key) x -> SharedKey depth key
forall x. SharedKey depth key -> Rep (SharedKey depth key) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (depth :: Depth) key x.
Rep (SharedKey depth key) x -> SharedKey depth key
forall (depth :: Depth) key x.
SharedKey depth key -> Rep (SharedKey depth key) x
$cto :: forall (depth :: Depth) key x.
Rep (SharedKey depth key) x -> SharedKey depth key
$cfrom :: forall (depth :: Depth) key x.
SharedKey depth key -> Rep (SharedKey depth key) x
Generic, Int -> SharedKey depth key -> ShowS
[SharedKey depth key] -> ShowS
SharedKey depth key -> String
(Int -> SharedKey depth key -> ShowS)
-> (SharedKey depth key -> String)
-> ([SharedKey depth key] -> ShowS)
-> Show (SharedKey depth key)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (depth :: Depth) key.
Show key =>
Int -> SharedKey depth key -> ShowS
forall (depth :: Depth) key.
Show key =>
[SharedKey depth key] -> ShowS
forall (depth :: Depth) key.
Show key =>
SharedKey depth key -> String
showList :: [SharedKey depth key] -> ShowS
$cshowList :: forall (depth :: Depth) key.
Show key =>
[SharedKey depth key] -> ShowS
show :: SharedKey depth key -> String
$cshow :: forall (depth :: Depth) key.
Show key =>
SharedKey depth key -> String
showsPrec :: Int -> SharedKey depth key -> ShowS
$cshowsPrec :: forall (depth :: Depth) key.
Show key =>
Int -> SharedKey depth key -> ShowS
Show, SharedKey depth key -> SharedKey depth key -> Bool
(SharedKey depth key -> SharedKey depth key -> Bool)
-> (SharedKey depth key -> SharedKey depth key -> Bool)
-> Eq (SharedKey depth key)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (depth :: Depth) key.
Eq key =>
SharedKey depth key -> SharedKey depth key -> Bool
/= :: SharedKey depth key -> SharedKey depth key -> Bool
$c/= :: forall (depth :: Depth) key.
Eq key =>
SharedKey depth key -> SharedKey depth key -> Bool
== :: SharedKey depth key -> SharedKey depth key -> Bool
$c== :: forall (depth :: Depth) key.
Eq key =>
SharedKey depth key -> SharedKey depth key -> Bool
Eq)

instance (NFData key) => NFData (SharedKey depth key)

constructAddressFromIx
    :: forall (n :: NetworkDiscriminant).  Typeable n
    => Role
    -> ScriptTemplate
    -> Maybe ScriptTemplate
    -> Index 'Soft 'ScriptK
    -> Address
constructAddressFromIx :: Role
-> ScriptTemplate
-> Maybe ScriptTemplate
-> Index 'Soft 'ScriptK
-> Address
constructAddressFromIx Role
role ScriptTemplate
pTemplate Maybe ScriptTemplate
dTemplate Index 'Soft 'ScriptK
ix =
    let 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
        paymentCredential :: Script KeyHash -> Credential 'PaymentK
paymentCredential = ScriptHash -> Credential 'PaymentK
PaymentFromScript (ScriptHash -> Credential 'PaymentK)
-> (Script KeyHash -> ScriptHash)
-> Script KeyHash
-> Credential 'PaymentK
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Script KeyHash -> ScriptHash
toScriptHash
        tag :: NetworkTag
tag = Typeable n => NetworkTag
forall (n :: NetworkDiscriminant). Typeable n => NetworkTag
toNetworkTag @n
        createBaseAddress :: Script KeyHash -> Script KeyHash -> ByteString
createBaseAddress Script KeyHash
pScript' Script KeyHash
dScript' =
            Address -> ByteString
CA.unAddress (Address -> ByteString) -> Address -> ByteString
forall a b. (a -> b) -> a -> b
$
            NetworkDiscriminant Shelley
-> Credential 'PaymentK -> Credential 'DelegationK -> Address
delegationAddress NetworkDiscriminant Shelley
NetworkTag
tag
            (Script KeyHash -> Credential 'PaymentK
paymentCredential Script KeyHash
pScript') (Script KeyHash -> Credential 'DelegationK
delegationCredential Script KeyHash
dScript')
        createEnterpriseAddress :: Script KeyHash -> ByteString
createEnterpriseAddress Script KeyHash
pScript' =
            Address -> ByteString
CA.unAddress (Address -> ByteString) -> Address -> ByteString
forall a b. (a -> b) -> a -> b
$
            NetworkDiscriminant Shelley -> Credential 'PaymentK -> Address
paymentAddress NetworkDiscriminant Shelley
NetworkTag
tag
            (Script KeyHash -> Credential 'PaymentK
paymentCredential Script KeyHash
pScript')
        role' :: Role
role' = case Role
role of
            Role
UtxoExternal -> Role
CA.UTxOExternal
            Role
UtxoInternal -> Role
CA.UTxOInternal
            Role
MutableAccount ->
                String -> Role
forall a. HasCallStack => String -> a
error String
"role is specified only for payment credential"
        pScript :: Script KeyHash
pScript =
            Role -> ScriptTemplate -> Index 'Soft 'ScriptK -> Script KeyHash
replaceCosignersWithVerKeys Role
role' ScriptTemplate
pTemplate Index 'Soft 'ScriptK
ix
        dScript :: ScriptTemplate -> Script KeyHash
dScript ScriptTemplate
s =
            Role -> ScriptTemplate -> Index 'Soft 'ScriptK -> Script KeyHash
replaceCosignersWithVerKeys Role
CA.Stake ScriptTemplate
s Index 'Soft 'ScriptK
forall a. Bounded a => a
minBound
    in ByteString -> Address
Address (ByteString -> Address) -> ByteString -> Address
forall a b. (a -> b) -> a -> b
$ case Maybe ScriptTemplate
dTemplate of
        Just ScriptTemplate
dTemplate' ->
            Script KeyHash -> Script KeyHash -> ByteString
createBaseAddress Script KeyHash
pScript (ScriptTemplate -> Script KeyHash
dScript ScriptTemplate
dTemplate')
        Maybe ScriptTemplate
Nothing ->
            Script KeyHash -> ByteString
createEnterpriseAddress Script KeyHash
pScript

replaceCosignersWithVerKeys
    :: CA.Role
    -> ScriptTemplate
    -> Index 'Soft 'ScriptK
    -> Script KeyHash
replaceCosignersWithVerKeys :: Role -> ScriptTemplate -> Index 'Soft 'ScriptK -> Script KeyHash
replaceCosignersWithVerKeys Role
role' (ScriptTemplate Map Cosigner XPub
xpubs Script Cosigner
scriptTemplate) Index 'Soft 'ScriptK
ix =
    Script Cosigner -> Script KeyHash
replaceCosigner Script Cosigner
scriptTemplate
  where
    replaceCosigner :: Script Cosigner -> Script KeyHash
    replaceCosigner :: Script Cosigner -> Script KeyHash
replaceCosigner = \case
        RequireSignatureOf Cosigner
c -> KeyHash -> Script KeyHash
forall elem. elem -> Script elem
RequireSignatureOf (KeyHash -> Script KeyHash) -> KeyHash -> Script KeyHash
forall a b. (a -> b) -> a -> b
$ Cosigner -> KeyHash
toKeyHash Cosigner
c
        RequireAllOf [Script Cosigner]
xs      -> [Script KeyHash] -> Script KeyHash
forall elem. [Script elem] -> Script elem
RequireAllOf ((Script Cosigner -> Script KeyHash)
-> [Script Cosigner] -> [Script KeyHash]
forall a b. (a -> b) -> [a] -> [b]
map Script Cosigner -> Script KeyHash
replaceCosigner [Script Cosigner]
xs)
        RequireAnyOf [Script Cosigner]
xs      -> [Script KeyHash] -> Script KeyHash
forall elem. [Script elem] -> Script elem
RequireAnyOf ((Script Cosigner -> Script KeyHash)
-> [Script Cosigner] -> [Script KeyHash]
forall a b. (a -> b) -> [a] -> [b]
map Script Cosigner -> Script KeyHash
replaceCosigner [Script Cosigner]
xs)
        RequireSomeOf Word8
m [Script Cosigner]
xs   -> Word8 -> [Script KeyHash] -> Script KeyHash
forall elem. Word8 -> [Script elem] -> Script elem
RequireSomeOf Word8
m ((Script Cosigner -> Script KeyHash)
-> [Script Cosigner] -> [Script KeyHash]
forall a b. (a -> b) -> [a] -> [b]
map Script Cosigner -> Script KeyHash
replaceCosigner [Script Cosigner]
xs)
        ActiveFromSlot Natural
s     -> Natural -> Script KeyHash
forall elem. Natural -> Script elem
ActiveFromSlot Natural
s
        ActiveUntilSlot Natural
s    -> Natural -> Script KeyHash
forall elem. Natural -> Script elem
ActiveUntilSlot Natural
s
    convertIndex :: Index 'Soft 'ScriptK -> CA.Index 'CA.Soft 'CA.PaymentK
    convertIndex :: Index 'Soft 'ScriptK -> Index 'Soft 'PaymentK
convertIndex = Maybe (Index 'Soft 'PaymentK) -> Index 'Soft 'PaymentK
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Index 'Soft 'PaymentK) -> Index 'Soft 'PaymentK)
-> (Index 'Soft 'ScriptK -> Maybe (Index 'Soft 'PaymentK))
-> Index 'Soft 'ScriptK
-> Index 'Soft 'PaymentK
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Maybe (Index 'Soft 'PaymentK)
forall ix (derivationType :: DerivationType) (depth :: Depth).
(ix ~ Index derivationType depth, Bounded ix) =>
Word32 -> Maybe ix
CA.indexFromWord32 (Word32 -> Maybe (Index 'Soft 'PaymentK))
-> (Index 'Soft 'ScriptK -> Word32)
-> Index 'Soft 'ScriptK
-> Maybe (Index 'Soft 'PaymentK)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32)
-> (Index 'Soft 'ScriptK -> Int) -> Index 'Soft 'ScriptK -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index 'Soft 'ScriptK -> Int
forall a. Enum a => a -> Int
fromEnum
    toKeyHash :: Cosigner -> KeyHash
    toKeyHash :: Cosigner -> KeyHash
toKeyHash Cosigner
c =
        let (Just Shared 'AccountK XPub
accXPub) =
                String
-> Maybe (Shared 'AccountK XPub)
-> (Maybe (Shared 'AccountK XPub) -> Bool)
-> Maybe (Shared 'AccountK XPub)
forall a. HasCallStack => String -> a -> (a -> Bool) -> a
invariant String
"we should have accXPubs of all cosigners at this point"
                (XPub -> Shared 'AccountK XPub
forall (depth :: Depth). XPub -> Shared depth XPub
liftXPub (XPub -> Shared 'AccountK XPub)
-> Maybe XPub -> Maybe (Shared 'AccountK XPub)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cosigner -> Map Cosigner XPub -> Maybe XPub
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Cosigner
c Map Cosigner XPub
xpubs)
                Maybe (Shared 'AccountK XPub) -> Bool
forall a. Maybe a -> Bool
isJust
            verKey :: Shared 'ScriptK XPub
verKey = Shared 'AccountK XPub
-> Index 'Soft 'PaymentK -> Shared 'ScriptK XPub
deriveMultisigPublicKey Shared 'AccountK XPub
accXPub (Index 'Soft 'ScriptK -> Index 'Soft 'PaymentK
convertIndex Index 'Soft 'ScriptK
ix)
        in KeyRole -> Shared 'ScriptK XPub -> KeyHash
forall (key :: Depth). KeyRole -> Shared key XPub -> KeyHash
hashKey KeyRole
walletRole Shared 'ScriptK XPub
verKey
    walletRole :: KeyRole
walletRole = case Role
role' of
        Role
CA.UTxOExternal -> KeyRole
CA.Payment
        Role
CA.UTxOInternal -> KeyRole
CA.Payment
        Role
CA.Stake -> KeyRole
CA.Delegation
    deriveMultisigPublicKey :: Shared 'AccountK XPub
-> Index 'Soft 'PaymentK -> Shared 'ScriptK XPub
deriveMultisigPublicKey Shared 'AccountK XPub
accXPub = case Role
role' of
        Role
CA.UTxOExternal -> Shared 'AccountK XPub
-> Role -> Index 'Soft 'PaymentK -> Shared 'ScriptK XPub
deriveAddressPublicKey Shared 'AccountK XPub
accXPub Role
role'
        Role
CA.UTxOInternal -> Shared 'AccountK XPub
-> Role -> Index 'Soft 'PaymentK -> Shared 'ScriptK XPub
deriveAddressPublicKey Shared 'AccountK XPub
accXPub Role
role'
        Role
CA.Stake -> Shared 'AccountK XPub
-> Index 'Soft 'PaymentK -> Shared 'ScriptK XPub
deriveDelegationPublicKey Shared 'AccountK XPub
accXPub

-- | Convert 'NetworkDiscriminant type parameter to
-- 'Cardano.Address.NetworkTag'.
toNetworkTag :: forall (n :: NetworkDiscriminant). Typeable n => CA.NetworkTag
toNetworkTag :: NetworkTag
toNetworkTag = case TypeRep n -> TypeRep 'Mainnet -> Maybe (n :~: 'Mainnet)
forall k (f :: k -> *) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality (Typeable n => TypeRep n
forall k (a :: k). Typeable a => TypeRep a
typeRep @n) (Typeable 'Mainnet => TypeRep 'Mainnet
forall k (a :: k). Typeable a => TypeRep a
typeRep @'Mainnet) of
    Just n :~: 'Mainnet
Refl -> Word32 -> NetworkTag
CA.NetworkTag Word32
1
    Maybe (n :~: 'Mainnet)
Nothing -> Word32 -> NetworkTag
CA.NetworkTag Word32
0 -- fixme: Not all testnets have NetworkTag=0