{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- Copyright: © 2018-2021 IOHK
-- License: Apache-2.0
--
-- Derivation of policy keys which are used to create scripts for the purposes
-- of minting and burning. Derived according to CIP-1855
-- (https://github.com/cardano-foundation/CIPs/blob/b2e9d02cb9a71ba9e754a432c78197428abf7e4c/CIP-1855/CIP-1855.md).
--
-- The policy keys are derived from the following path:
--
-- m / purpose' / coin_type' / policy_ix'
-- m / 1855'    / 1815'      / [2^31 .. 2^32-1]'
--
-- Where purpose' and coin_type' are fixed, and each new policy_ix' represents a
-- different policy key.

module Cardano.Wallet.Primitive.AddressDerivation.MintBurn
    ( -- * Constants
      purposeCIP1855
      -- * Helpers
    , derivePolicyKeyAndHash
    , derivePolicyPrivateKey
    , policyDerivationPath
    , toTokenMapAndScript
    , toTokenPolicyId
    , scriptSlotIntervals
    , withinSlotInterval
    ) where

import Prelude

import Cardano.Address.Derivation
    ( XPrv, XPub )
import Cardano.Address.Script
    ( Cosigner, KeyHash, Script (..), ScriptHash (..), toScriptHash )
import Cardano.Crypto.Wallet
    ( deriveXPrv )
import Cardano.Crypto.Wallet.Types
    ( DerivationScheme (DerivationScheme2) )
import Cardano.Wallet.Primitive.AddressDerivation
    ( Depth (..)
    , DerivationIndex (..)
    , DerivationType (..)
    , Index (..)
    , WalletKey
    , getIndex
    , getRawKey
    , hashVerificationKey
    , liftRawKey
    , publicKey
    )
import Cardano.Wallet.Primitive.AddressDiscovery
    ( coinTypeAda )
import Cardano.Wallet.Primitive.Passphrase
    ( Passphrase (..) )
import Cardano.Wallet.Primitive.Types
    ( SlotNo (..) )
import Cardano.Wallet.Primitive.Types.Hash
    ( Hash (..) )
import Cardano.Wallet.Primitive.Types.TokenMap
    ( AssetId (..) )
import Cardano.Wallet.Primitive.Types.TokenPolicy
    ( TokenName, TokenPolicyId (..) )
import Cardano.Wallet.Primitive.Types.TokenQuantity
    ( TokenQuantity (..) )
import Cardano.Wallet.Util
    ( invariant )
import Data.IntCast
    ( intCast )
import Data.Interval
    ( Interval, (<=..<=) )
import Data.List.NonEmpty
    ( NonEmpty )
import Data.Map.Strict
    ( Map )
import Data.Maybe
    ( isJust )
import Data.Word
    ( Word64 )
import Numeric.Natural
    ( Natural )

import qualified Cardano.Address.Script as CA
import qualified Data.Interval as I
import qualified Data.List as L
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map


-- | Purpose for forged policy keys is a constant set to 1855' (or 0x8000073F)
-- following the original CIP-1855: "Forging policy keys for HD Wallets".
--
-- It indicates that the subtree of this node is used according to this
-- specification.
--
-- Hardened derivation is used at this level.
purposeCIP1855 :: Index 'Hardened 'PurposeK
purposeCIP1855 :: Index 'Hardened 'PurposeK
purposeCIP1855 = Int -> Index 'Hardened 'PurposeK
forall a. Enum a => Int -> a
toEnum Int
0x8000073F

-- | Derive the policy private key that should be used to create mint/burn
-- scripts.
derivePolicyPrivateKey
    :: Passphrase purpose
    -- ^ Passphrase for wallet
    -> XPrv
    -- ^ Root private key to derive policy private key from
    -> Index 'Hardened 'PolicyK
    -- ^ Index of policy script
    -> XPrv
    -- ^ Policy private key
derivePolicyPrivateKey :: Passphrase purpose -> XPrv -> Index 'Hardened 'PolicyK -> XPrv
derivePolicyPrivateKey (Passphrase ScrubbedBytes
pwd) XPrv
rootXPrv (Index Word32
policyIx) =
    let
        purposeXPrv :: XPrv
purposeXPrv = -- lvl1 derivation; hardened derivation of purpose'
            DerivationScheme -> ScrubbedBytes -> XPrv -> Word32 -> XPrv
forall passPhrase.
ByteArrayAccess passPhrase =>
DerivationScheme -> passPhrase -> XPrv -> Word32 -> XPrv
deriveXPrv DerivationScheme
DerivationScheme2 ScrubbedBytes
pwd XPrv
rootXPrv (Index 'Hardened 'PurposeK -> Word32
forall (derivationType :: DerivationType) (level :: Depth).
Index derivationType level -> Word32
getIndex Index 'Hardened 'PurposeK
purposeCIP1855)
        coinTypeXPrv :: XPrv
coinTypeXPrv = -- lvl2 derivation; hardened derivation of coin_type'
            DerivationScheme -> ScrubbedBytes -> XPrv -> Word32 -> XPrv
forall passPhrase.
ByteArrayAccess passPhrase =>
DerivationScheme -> passPhrase -> XPrv -> Word32 -> XPrv
deriveXPrv DerivationScheme
DerivationScheme2 ScrubbedBytes
pwd XPrv
purposeXPrv (Index 'Hardened 'CoinTypeK -> Word32
forall (derivationType :: DerivationType) (level :: Depth).
Index derivationType level -> Word32
getIndex Index 'Hardened 'CoinTypeK
coinTypeAda)
     -- lvl3 derivation; hardened derivation of policy' index
    in DerivationScheme -> ScrubbedBytes -> XPrv -> Word32 -> XPrv
forall passPhrase.
ByteArrayAccess passPhrase =>
DerivationScheme -> passPhrase -> XPrv -> Word32 -> XPrv
deriveXPrv DerivationScheme
DerivationScheme2 ScrubbedBytes
pwd XPrv
coinTypeXPrv Word32
policyIx

-- | Derive the policy private key that should be used to create mint/burn
-- scripts, as well as the key hash of the policy public key.
derivePolicyKeyAndHash
  :: WalletKey key
  => Passphrase "encryption"
  -- ^ Passphrase for wallet
  -> key 'RootK XPrv
  -- ^ Root private key to derive policy private key from
  -> Index 'Hardened 'PolicyK
  -- ^ Index of policy script
  -> (key 'PolicyK XPrv, KeyHash)
  -- ^ Policy private key
derivePolicyKeyAndHash :: Passphrase "encryption"
-> key 'RootK XPrv
-> Index 'Hardened 'PolicyK
-> (key 'PolicyK XPrv, KeyHash)
derivePolicyKeyAndHash Passphrase "encryption"
pwd key 'RootK XPrv
rootPrv Index 'Hardened 'PolicyK
policyIx = (key 'PolicyK XPrv
forall (depth :: Depth). key depth XPrv
policyK, KeyHash
vkeyHash)
  where
    policyK :: key depth XPrv
policyK = XPrv -> key depth XPrv
forall (key :: Depth -> * -> *) raw (depth :: Depth).
WalletKey key =>
raw -> key depth raw
liftRawKey XPrv
policyPrv
    policyPrv :: XPrv
policyPrv = Passphrase "encryption" -> XPrv -> Index 'Hardened 'PolicyK -> XPrv
forall (purpose :: Symbol).
Passphrase purpose -> XPrv -> Index 'Hardened 'PolicyK -> XPrv
derivePolicyPrivateKey Passphrase "encryption"
pwd (key 'RootK XPrv -> XPrv
forall (key :: Depth -> * -> *) (depth :: Depth) raw.
WalletKey key =>
key depth raw -> raw
getRawKey key 'RootK XPrv
rootPrv) Index 'Hardened 'PolicyK
policyIx
    vkeyHash :: KeyHash
vkeyHash = KeyRole -> key Any XPub -> KeyHash
forall (key :: Depth -> * -> *) (depth :: Depth).
WalletKey key =>
KeyRole -> key depth XPub -> KeyHash
hashVerificationKey KeyRole
CA.Payment (key Any XPrv -> key Any XPub
forall (key :: Depth -> * -> *) (depth :: Depth).
WalletKey key =>
key depth XPrv -> key depth XPub
publicKey key Any XPrv
forall (depth :: Depth). key depth XPrv
policyK)

policyDerivationPath
    :: NonEmpty DerivationIndex
policyDerivationPath :: NonEmpty DerivationIndex
policyDerivationPath =  [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
purposeCIP1855
    , 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
coinTypeAda
    , Word32 -> DerivationIndex
DerivationIndex (Word32 -> DerivationIndex) -> Word32 -> DerivationIndex
forall a b. (a -> b) -> a -> b
$ Index 'Hardened 'PolicyK -> Word32
forall (derivationType :: DerivationType) (level :: Depth).
Index derivationType level -> Word32
getIndex Index 'Hardened 'PolicyK
policyIx
    ]
  where
    policyIx :: Index 'Hardened 'PolicyK
    policyIx :: Index 'Hardened 'PolicyK
policyIx = Index 'Hardened 'PolicyK
forall a. Bounded a => a
minBound

toTokenPolicyId
    :: forall key. WalletKey key
    => Script Cosigner
    -> Map Cosigner XPub
    -> TokenPolicyId
toTokenPolicyId :: Script Cosigner -> Map Cosigner XPub -> TokenPolicyId
toTokenPolicyId Script Cosigner
scriptTempl Map Cosigner XPub
cosignerMap =
      Hash "TokenPolicy" -> TokenPolicyId
UnsafeTokenPolicyId
    (Hash "TokenPolicy" -> TokenPolicyId)
-> (Script KeyHash -> Hash "TokenPolicy")
-> Script KeyHash
-> TokenPolicyId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Hash "TokenPolicy"
forall (tag :: Symbol). ByteString -> Hash tag
Hash
    (ByteString -> Hash "TokenPolicy")
-> (Script KeyHash -> ByteString)
-> Script KeyHash
-> Hash "TokenPolicy"
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptHash -> ByteString
unScriptHash
    (ScriptHash -> ByteString)
-> (Script KeyHash -> ScriptHash) -> Script KeyHash -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Script KeyHash -> ScriptHash
toScriptHash
    (Script KeyHash -> TokenPolicyId)
-> Script KeyHash -> TokenPolicyId
forall a b. (a -> b) -> a -> b
$ Map Cosigner XPub -> Script Cosigner -> Script KeyHash
forall (key :: Depth -> * -> *).
WalletKey key =>
Map Cosigner XPub -> Script Cosigner -> Script KeyHash
replaceCosigner @key Map Cosigner XPub
cosignerMap Script Cosigner
scriptTempl

toTokenMapAndScript
    :: forall key. WalletKey key
    => Script Cosigner
    -> Map Cosigner XPub
    -> TokenName
    -> Natural
    -> (AssetId, TokenQuantity, Script KeyHash)
toTokenMapAndScript :: Script Cosigner
-> Map Cosigner XPub
-> TokenName
-> Natural
-> (AssetId, TokenQuantity, Script KeyHash)
toTokenMapAndScript Script Cosigner
scriptTempl Map Cosigner XPub
cosignerMap TokenName
tName Natural
val =
    ( TokenPolicyId -> TokenName -> AssetId
AssetId (Script Cosigner -> Map Cosigner XPub -> TokenPolicyId
forall (key :: Depth -> * -> *).
WalletKey key =>
Script Cosigner -> Map Cosigner XPub -> TokenPolicyId
toTokenPolicyId @key Script Cosigner
scriptTempl Map Cosigner XPub
cosignerMap) TokenName
tName
    , Natural -> TokenQuantity
TokenQuantity Natural
val
    , Map Cosigner XPub -> Script Cosigner -> Script KeyHash
forall (key :: Depth -> * -> *).
WalletKey key =>
Map Cosigner XPub -> Script Cosigner -> Script KeyHash
replaceCosigner @key Map Cosigner XPub
cosignerMap Script Cosigner
scriptTempl
    )

replaceCosigner
    :: forall key. WalletKey key
    => Map Cosigner XPub
    -> Script Cosigner
    -> Script KeyHash
replaceCosigner :: Map Cosigner XPub -> Script Cosigner -> Script KeyHash
replaceCosigner Map Cosigner XPub
cosignerMap = \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 (Map Cosigner XPub -> Script Cosigner -> Script KeyHash
forall (key :: Depth -> * -> *).
WalletKey key =>
Map Cosigner XPub -> Script Cosigner -> Script KeyHash
replaceCosigner @key Map Cosigner XPub
cosignerMap) [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 (Map Cosigner XPub -> Script Cosigner -> Script KeyHash
forall (key :: Depth -> * -> *).
WalletKey key =>
Map Cosigner XPub -> Script Cosigner -> Script KeyHash
replaceCosigner @key Map Cosigner XPub
cosignerMap) [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 (Map Cosigner XPub -> Script Cosigner -> Script KeyHash
forall (key :: Depth -> * -> *).
WalletKey key =>
Map Cosigner XPub -> Script Cosigner -> Script KeyHash
replaceCosigner @key Map Cosigner XPub
cosignerMap) [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
  where
    toKeyHash :: Cosigner -> KeyHash
    toKeyHash :: Cosigner -> KeyHash
toKeyHash Cosigner
c =
        let Just XPub
xpub =
                String -> Maybe XPub -> (Maybe XPub -> Bool) -> Maybe XPub
forall a. HasCallStack => String -> a -> (a -> Bool) -> a
invariant String
"we should have xpubs of all cosigners at this point"
                (Cosigner -> Map Cosigner XPub -> Maybe XPub
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Cosigner
c Map Cosigner XPub
cosignerMap)
                Maybe XPub -> Bool
forall a. Maybe a -> Bool
isJust
        in KeyRole -> key Any XPub -> KeyHash
forall (key :: Depth -> * -> *) (depth :: Depth).
WalletKey key =>
KeyRole -> key depth XPub -> KeyHash
hashVerificationKey @key KeyRole
CA.Policy (XPub -> key Any XPub
forall (key :: Depth -> * -> *) raw (depth :: Depth).
WalletKey key =>
raw -> key depth raw
liftRawKey XPub
xpub)

scriptSlotIntervals
    :: Script a
    -> [Interval Natural]
scriptSlotIntervals :: Script a -> [Interval Natural]
scriptSlotIntervals = \case
    RequireSignatureOf a
_ ->
        [Interval Natural
allSlots]
    RequireAllOf [Script a]
xs ->
        let ([Script a]
timelocks, [Script a]
rest) = (Script a -> Bool) -> [Script a] -> ([Script a], [Script a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition Script a -> Bool
forall elem. Script elem -> Bool
isTimelockOrSig [Script a]
xs
        in
        [Interval Natural] -> [Interval Natural]
trimAllSlots
            ([Interval Natural] -> [Interval Natural])
-> [Interval Natural] -> [Interval Natural]
forall a b. (a -> b) -> a -> b
$ [Interval Natural] -> Interval Natural
forall r. Ord r => [Interval r] -> Interval r
I.intersections ((Script a -> [Interval Natural])
-> [Script a] -> [Interval Natural]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Script a -> [Interval Natural]
forall a. Script a -> [Interval Natural]
scriptSlotIntervals [Script a]
timelocks)
            Interval Natural -> [Interval Natural] -> [Interval Natural]
forall a. a -> [a] -> [a]
: (Script a -> [Interval Natural])
-> [Script a] -> [Interval Natural]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Script a -> [Interval Natural]
forall a. Script a -> [Interval Natural]
scriptSlotIntervals [Script a]
rest
    RequireAnyOf [Script a]
xs ->
        [Interval Natural] -> [Interval Natural]
trimAllSlots ([Interval Natural] -> [Interval Natural])
-> [Interval Natural] -> [Interval Natural]
forall a b. (a -> b) -> a -> b
$ (Script a -> [Interval Natural])
-> [Script a] -> [Interval Natural]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Script a -> [Interval Natural]
forall a. Script a -> [Interval Natural]
scriptSlotIntervals [Script a]
xs
    RequireSomeOf Word8
_ [Script a]
xs ->
        [Interval Natural] -> [Interval Natural]
trimAllSlots ([Interval Natural] -> [Interval Natural])
-> [Interval Natural] -> [Interval Natural]
forall a b. (a -> b) -> a -> b
$ (Script a -> [Interval Natural])
-> [Script a] -> [Interval Natural]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Script a -> [Interval Natural]
forall a. Script a -> [Interval Natural]
scriptSlotIntervals [Script a]
xs
    ActiveFromSlot Natural
s ->
        [Natural -> Extended Natural
forall r. r -> Extended r
I.Finite Natural
s Extended Natural -> Extended Natural -> Interval Natural
forall r. Ord r => Extended r -> Extended r -> Interval r
<=..<= Extended Natural
maxSlot]
    ActiveUntilSlot Natural
s ->
        [Extended Natural
minSlot Extended Natural -> Extended Natural -> Interval Natural
forall r. Ord r => Extended r -> Extended r -> Interval r
<=..<= Natural -> Extended Natural
forall r. r -> Extended r
I.Finite Natural
s]
  where
    minSlot :: Extended Natural
minSlot = Natural -> Extended Natural
forall r. r -> Extended r
I.Finite (Natural -> Extended Natural) -> Natural -> Extended Natural
forall a b. (a -> b) -> a -> b
$ Word64 -> Natural
forall a b.
(Integral a, Integral b, IsIntSubType a b ~ 'True) =>
a -> b
intCast (Word64 -> Natural) -> Word64 -> Natural
forall a b. (a -> b) -> a -> b
$ Bounded Word64 => Word64
forall a. Bounded a => a
minBound @Word64
    maxSlot :: Extended Natural
maxSlot = Natural -> Extended Natural
forall r. r -> Extended r
I.Finite (Natural -> Extended Natural) -> Natural -> Extended Natural
forall a b. (a -> b) -> a -> b
$ Word64 -> Natural
forall a b.
(Integral a, Integral b, IsIntSubType a b ~ 'True) =>
a -> b
intCast (Word64 -> Natural) -> Word64 -> Natural
forall a b. (a -> b) -> a -> b
$ Bounded Word64 => Word64
forall a. Bounded a => a
maxBound @Word64
    allSlots :: Interval Natural
allSlots = Extended Natural
minSlot Extended Natural -> Extended Natural -> Interval Natural
forall r. Ord r => Extended r -> Extended r -> Interval r
<=..<= Extended Natural
maxSlot

    isTimelockOrSig :: Script elem -> Bool
isTimelockOrSig = \case
        ActiveFromSlot Natural
_ -> Bool
True
        ActiveUntilSlot Natural
_ -> Bool
True
        RequireSignatureOf elem
_ -> Bool
True
        Script elem
_ -> Bool
False

    trimAllSlots :: [Interval Natural] -> [Interval Natural]
trimAllSlots [Interval Natural]
interval =
        let notAllSlots :: [Interval Natural]
notAllSlots = (Interval Natural -> Bool)
-> [Interval Natural] -> [Interval Natural]
forall a. (a -> Bool) -> [a] -> [a]
filter (Interval Natural -> Interval Natural -> Bool
forall a. Eq a => a -> a -> Bool
/= Interval Natural
allSlots) [Interval Natural]
interval
        in
        if [Interval Natural] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null [Interval Natural]
notAllSlots
        then [Interval Natural]
interval
        else [Interval Natural]
notAllSlots

-- tx validity interval must be a subset of a interval from script's timelock
-- tx validity interval is defined by specifying (from,to) slot interval
withinSlotInterval
    :: SlotNo
    -> SlotNo
    -> [Interval Natural]
    -> Bool
withinSlotInterval :: SlotNo -> SlotNo -> [Interval Natural] -> Bool
withinSlotInterval (SlotNo Word64
from) (SlotNo Word64
to) =
    (Interval Natural -> Bool) -> [Interval Natural] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
L.any (Interval Natural
txValidityInterval Interval Natural -> Interval Natural -> Bool
forall r. Ord r => Interval r -> Interval r -> Bool
`I.isSubsetOf`)
  where
    txValidityInterval :: Interval Natural
txValidityInterval =
        Natural -> Extended Natural
forall r. r -> Extended r
I.Finite (Word64 -> Natural
forall a b.
(Integral a, Integral b, IsIntSubType a b ~ 'True) =>
a -> b
intCast Word64
from) Extended Natural -> Extended Natural -> Interval Natural
forall r. Ord r => Extended r -> Extended r -> Interval r
<=..<= Natural -> Extended Natural
forall r. r -> Extended r
I.Finite (Word64 -> Natural
forall a b.
(Integral a, Integral b, IsIntSubType a b ~ 'True) =>
a -> b
intCast Word64
to)