MintBurnSpec.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Wallet.Address.Derivation.MintBurnSpec
  ( spec
  )
where

import Cardano.Address.Derivation
  ( XPrv
  , XPub
  , xprvToBytes
  )
import Cardano.Address.Script
  ( KeyHash
  , KeyRole (..)
  , Script (..)
  , keyHashFromBytes
  )
import Cardano.Address.Script qualified as CA
import Cardano.Mnemonic
  ( Mnemonic
  , SomeMnemonic (..)
  )
import Cardano.Wallet.Address.Derivation
  ( Depth (..)
  , DerivationType (..)
  , Index (..)
  )
import Cardano.Wallet.Address.Derivation.MintBurn
  ( derivePolicyPrivateKey
  , scriptSlotIntervals
  , withinSlotInterval
  )
import Cardano.Wallet.Address.Derivation.Shelley
  ( ShelleyKey
  )
import Cardano.Wallet.Address.Derivation.Shelley qualified as Shelley
import Cardano.Wallet.Address.DerivationSpec
  (
  )
import Cardano.Wallet.Address.Keys.MintBurn
  ( derivePolicyKeyAndHash
  )
import Cardano.Wallet.Address.Keys.WalletKey
  ( getRawKey
  , hashVerificationKey
  , liftRawKey
  , publicKey
  )
import Cardano.Wallet.Flavor
  ( KeyFlavorS (..)
  )
import Cardano.Wallet.Primitive.Passphrase
  ( Passphrase
  )
import Cardano.Wallet.Primitive.Types
  ( SlotNo (..)
  )
import Cardano.Wallet.Unsafe
  ( unsafeBech32Decode
  , unsafeFromHex
  , unsafeMkMnemonic
  , unsafeXPrv
  )
import Codec.Binary.Encoding
  ( fromBase16
  )
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as BL
import Data.Function
  ( (&)
  )
import Data.IntCast
  ( intCast
  )
import Data.Interval
  ( Interval
  , empty
  , (<=..<=)
  )
import Data.Interval qualified as I
import Data.Text
  ( Text
  )
import Data.Text.Encoding qualified as T
import Data.Word
  ( Word64
  )
import GHC.TypeNats
  ( KnownNat
  )
import Numeric.Natural
  ( Natural
  )
import Test.Hspec
  ( Expectation
  , Spec
  , describe
  , it
  , shouldBe
  )
import Test.QuickCheck
  ( Arbitrary (..)
  , Property
  , property
  , vector
  , (=/=)
  , (===)
  )
import Test.QuickCheck.Arbitrary
  ( arbitraryBoundedEnum
  )
import Prelude

spec :: Spec
spec = do
  describe "Mint/Burn Policy key Address Derivation Properties" $ do
    let
      minSlot = I.Finite $ intCast $ minBound @Word64
    let
      maxSlot = I.Finite $ intCast $ maxBound @Word64
    let
      hashKeyTxt :: Text
      hashKeyTxt =
        "deeae4e895d8d57378125ed4fd540f9bf245d59f7936a504379cfc1e"
    let
      hashKey = toKeyHash hashKeyTxt

    it "Policy key derivation from master key works for various indexes"
      $ property prop_keyDerivationFromXPrv
    it "Policy public key hash matches private key"
      $ property prop_keyHashMatchesXPrv
    it "The same index always returns the same private key"
      $ property prop_keyDerivationSameIndexSameKey
    it "A different index always returns a different private key"
      $ property prop_keyDerivationDiffIndexDiffKey
    it
      "Using derivePolicyKeyAndHash returns same private key as using derivePolicyPrivateKey"
      $ property prop_keyDerivationRelation
    it
      "Deriving a policy key with cardano-address returns same result as cardano-wallet"
      $ do
        unit_comparePolicyKeys
          goldenTestMnemonic
          (Index 0x80000000)
          "acct_xsk1tqqqnvtppk994fxm05wtlvp6uuu58srue9st8ew29vr5mxxf89tj2ze05pm8qjkyfetpzl58jkgx6dd3s96szhyxfajpc2gxv22xef0ems2cnvh5d5xjemgghg9m8489v6c9rvnt9za2pruyrtkp5y77l5ujxeug"
        -- Child key 1855H/1815H/0H generated by cardano-address CLI
        -- from test mnemonic
        unit_comparePolicyKeyHashes
          goldenTestMnemonic
          (Index 0x80000000)
          "6adb501348b99cd38172f355615d7c1d0b9d1e3fc69b565b85a98127"
        -- Hash of child key 1855H/1815H/0H generated by cardano-address
        -- CLI from test mnemonic
        unit_comparePolicyKeys
          goldenTestMnemonic
          (Index 0x80000010)
          "acct_xsk1rprds8krzhspy8xhkupk2270hzkexmkdga98zv5ns4x9d9kf89t4qp438a26sn62wsfldthkrvnwe6vnetuehgxyxt4hm46zsw03mknuwef0afcljmultpjjwx8zqm0ftnfkqucwvf5qr4gved6h3gnyeqcsur4p"
        -- Child key 1855H/1815H/16H generated by cardano-address CLI
        -- from test mnemonic
        unit_comparePolicyKeyHashes
          goldenTestMnemonic
          (Index 0x80000010)
          "1f07b91d27ca1cbf911ccfba254315733b3c908575ce2fc29d4c6965"
    -- Hash of child key 1855H/1815H/16H generated by
    -- cardano-address CLI from test mnemonic

    it "Unit tests for scriptSlotIntervals" $ do
      unit_scriptSlotIntervals
        hashKey
        [I.Finite @Natural 0 <=..<= maxSlot]

      unit_scriptSlotIntervals
        (RequireAllOf [hashKey, ActiveFromSlot 120])
        [I.Finite @Natural 120 <=..<= maxSlot]

      unit_scriptSlotIntervals
        (RequireAllOf [hashKey, ActiveUntilSlot 120])
        [minSlot <=..<= I.Finite @Natural 120]

      unit_scriptSlotIntervals
        (RequireAnyOf [hashKey, ActiveFromSlot 120])
        [I.Finite @Natural 120 <=..<= maxSlot]

      unit_scriptSlotIntervals
        (RequireAnyOf [hashKey, ActiveUntilSlot 120])
        [minSlot <=..<= I.Finite @Natural 120]

      unit_scriptSlotIntervals
        (RequireSomeOf 1 [hashKey, ActiveFromSlot 120])
        [I.Finite @Natural 120 <=..<= maxSlot]

      unit_scriptSlotIntervals
        (RequireSomeOf 1 [hashKey, ActiveUntilSlot 120])
        [minSlot <=..<= I.Finite @Natural 120]

      unit_scriptSlotIntervals
        ( RequireAllOf
            [ hashKey
            , ActiveFromSlot 100
            , ActiveUntilSlot 120
            ]
        )
        [I.Finite @Natural 100 <=..<= I.Finite @Natural 120]

      unit_scriptSlotIntervals
        ( RequireAllOf
            [ hashKey
            , ActiveFromSlot 120
            , ActiveUntilSlot 100
            ]
        )
        [empty]

      unit_scriptSlotIntervals
        ( RequireAnyOf
            [ hashKey
            , ActiveFromSlot 120
            , ActiveUntilSlot 100
            ]
        )
        [ I.Finite @Natural 120 <=..<= maxSlot
        , minSlot <=..<= I.Finite @Natural 100
        ]

      unit_scriptSlotIntervals
        ( RequireSomeOf
            1
            [ hashKey
            , ActiveFromSlot 120
            , ActiveUntilSlot 100
            ]
        )
        [ I.Finite @Natural 120 <=..<= maxSlot
        , minSlot <=..<= I.Finite @Natural 100
        ]

    it "Unit tests for withinSlotInterval" $ do
      unit_withinSlotInterval
        hashKey
        (SlotNo 10, SlotNo 100)
        True

      unit_withinSlotInterval
        (RequireAllOf [hashKey, ActiveFromSlot 120])
        (SlotNo 10, SlotNo 100)
        False

      unit_withinSlotInterval
        (RequireAllOf [hashKey, ActiveFromSlot 120])
        (SlotNo 10, SlotNo 130)
        False

      unit_withinSlotInterval
        (RequireAllOf [hashKey, ActiveUntilSlot 120])
        (SlotNo 10, SlotNo 100)
        True

      unit_withinSlotInterval
        (RequireAllOf [hashKey, ActiveUntilSlot 120])
        (SlotNo 10, SlotNo 130)
        False

      unit_withinSlotInterval
        ( RequireAllOf
            [ hashKey
            , ActiveFromSlot 100
            , ActiveUntilSlot 120
            ]
        )
        (SlotNo 100, SlotNo 120)
        True

      unit_withinSlotInterval
        ( RequireAllOf
            [ hashKey
            , ActiveFromSlot 100
            , ActiveUntilSlot 120
            ]
        )
        (SlotNo 90, SlotNo 100)
        False

      unit_withinSlotInterval
        ( RequireAllOf
            [ hashKey
            , ActiveFromSlot 100
            , ActiveUntilSlot 120
            ]
        )
        (SlotNo 110, SlotNo 130)
        False

      unit_withinSlotInterval
        ( RequireAnyOf
            [ hashKey
            , ActiveFromSlot 120
            , ActiveUntilSlot 100
            ]
        )
        (SlotNo 90, SlotNo 110)
        False

      unit_withinSlotInterval
        ( RequireAnyOf
            [ hashKey
            , ActiveFromSlot 120
            , ActiveUntilSlot 100
            ]
        )
        (SlotNo 110, SlotNo 150)
        False

      unit_withinSlotInterval
        ( RequireAnyOf
            [ hashKey
            , ActiveFromSlot 120
            , ActiveUntilSlot 100
            ]
        )
        (SlotNo 120, SlotNo 150)
        True

      unit_withinSlotInterval
        ( RequireAllOf
            [ hashKey
            , RequireAnyOf
                [ RequireAllOf [ActiveFromSlot 50, ActiveUntilSlot 100]
                , RequireAllOf [ActiveFromSlot 150, ActiveUntilSlot 200]
                ]
            ]
        )
        (SlotNo 60, SlotNo 90)
        True

      unit_withinSlotInterval
        ( RequireAllOf
            [ hashKey
            , RequireAnyOf
                [ RequireAllOf [ActiveFromSlot 50, ActiveUntilSlot 100]
                , RequireAllOf [ActiveFromSlot 150, ActiveUntilSlot 200]
                ]
            ]
        )
        (SlotNo 155, SlotNo 190)
        True

      unit_withinSlotInterval
        ( RequireAllOf
            [ hashKey
            , RequireAnyOf
                [ RequireAllOf [ActiveFromSlot 50, ActiveUntilSlot 100]
                , RequireAllOf [ActiveFromSlot 150, ActiveUntilSlot 200]
                ]
            ]
        )
        (SlotNo 155, SlotNo 210)
        False

      unit_withinSlotInterval
        ( RequireAllOf
            [ hashKey
            , RequireAnyOf
                [ RequireAllOf [ActiveFromSlot 50, ActiveUntilSlot 100]
                , RequireAllOf [ActiveFromSlot 150, ActiveUntilSlot 200]
                ]
            ]
        )
        (SlotNo 110, SlotNo 120)
        False

toKeyHash :: Text -> Script KeyHash
toKeyHash txt = case fromBase16 (T.encodeUtf8 txt) of
  Right bs -> case keyHashFromBytes (Payment, bs) of
    Just kh -> RequireSignatureOf kh
    Nothing -> error "Hash key not valid"
  Left _ -> error "Hash key not valid"

{-------------------------------------------------------------------------------
                               Properties
-------------------------------------------------------------------------------}

prop_keyDerivationFromXPrv
  :: Passphrase "encryption"
  -> XPrv
  -> Index 'Hardened 'PolicyK
  -> Property
prop_keyDerivationFromXPrv pwd masterkey policyIx =
  rndKey `seq` property () -- NOTE Making sure this doesn't throw
  where
    rndKey :: XPrv
    rndKey = derivePolicyPrivateKey pwd masterkey policyIx

prop_keyHashMatchesXPrv
  :: Passphrase "encryption"
  -> ShelleyKey 'RootK XPrv
  -> Index 'Hardened 'PolicyK
  -> Property
prop_keyHashMatchesXPrv pwd masterkey policyIx =
  hashVerificationKey
    ShelleyKeyS
    CA.Payment
    (getPublicKey rndKey)
    === keyHash
  where
    rndKey :: ShelleyKey 'PolicyK XPrv
    keyHash :: KeyHash
    (rndKey, keyHash) =
      derivePolicyKeyAndHash ShelleyKeyS pwd masterkey policyIx

    getPublicKey
      :: ShelleyKey 'PolicyK XPrv
      -> ShelleyKey 'CredFromScriptK XPub
    getPublicKey =
      publicKey kF
        . (liftRawKey kF :: XPrv -> ShelleyKey 'CredFromScriptK XPrv)
        . getRawKey kF
      where
        kF = ShelleyKeyS

prop_keyDerivationSameIndexSameKey
  :: Passphrase "encryption"
  -> XPrv
  -> Index 'Hardened 'PolicyK
  -> Property
prop_keyDerivationSameIndexSameKey pwd masterkey policyIx =
  key1 === key2
  where
    key1 :: XPrv
    key2 :: XPrv
    key1 = derivePolicyPrivateKey pwd masterkey policyIx
    key2 = derivePolicyPrivateKey pwd masterkey policyIx

prop_keyDerivationDiffIndexDiffKey
  :: Passphrase "encryption"
  -> XPrv
  -> Index 'Hardened 'PolicyK
  -> Index 'Hardened 'PolicyK
  -> Property
prop_keyDerivationDiffIndexDiffKey pwd masterkey policyIx1 policyIx2 =
  key1 =/= key2
  where
    key1 :: XPrv
    key2 :: XPrv
    key1 = derivePolicyPrivateKey pwd masterkey policyIx1
    key2 = derivePolicyPrivateKey pwd masterkey policyIx2

prop_keyDerivationRelation
  :: Passphrase "encryption"
  -> XPrv
  -> Index 'Hardened 'PolicyK
  -> Property
prop_keyDerivationRelation pwd masterkey policyIx =
  key1 === key2
  where
    key1 :: XPrv
    key1 = derivePolicyPrivateKey pwd masterkey policyIx

    keyAndHash :: (ShelleyKey 'PolicyK XPrv, KeyHash)
    keyAndHash =
      derivePolicyKeyAndHash
        ShelleyKeyS
        pwd
        (liftRawKey ShelleyKeyS masterkey)
        policyIx

    key2 :: XPrv
    key2 = getRawKey ShelleyKeyS $ fst keyAndHash

unit_comparePolicyKeys
  :: KnownNat n
  => Mnemonic n
  -> Index 'Hardened 'PolicyK
  -> Text
  -> Expectation
unit_comparePolicyKeys mnemonic index goldenPolicyKeyBech32 =
  let
    walletRootKey :: XPrv
    walletRootKey =
      Shelley.generateKeyFromSeed (SomeMnemonic mnemonic, Nothing) mempty
        & getRawKey ShelleyKeyS

    walletPolicyKey :: XPrv
    walletPolicyKey =
      derivePolicyPrivateKey (mempty :: Passphrase pwd) walletRootKey index

    walletPolicyKeyBytes :: BS.ByteString
    walletPolicyKeyBytes = xprvToBytes walletPolicyKey

    goldenPolicyKeyBytes :: BS.ByteString
    goldenPolicyKeyBytes =
      BL.toStrict $ unsafeBech32Decode goldenPolicyKeyBech32
  in
    walletPolicyKeyBytes `shouldBe` goldenPolicyKeyBytes

unit_comparePolicyKeyHashes
  :: KnownNat n
  => Mnemonic n
  -> Index 'Hardened 'PolicyK
  -> Text
  -> Expectation
unit_comparePolicyKeyHashes mnemonic index goldenPolicyKeyHashHex =
  let
    walletRootKey :: XPrv
    walletRootKey =
      Shelley.generateKeyFromSeed (SomeMnemonic mnemonic, Nothing) mempty
        & getRawKey ShelleyKeyS

    walletPolicyData :: (ShelleyKey 'PolicyK XPrv, KeyHash)
    walletPolicyData =
      derivePolicyKeyAndHash
        ShelleyKeyS
        (mempty :: Passphrase pwd)
        (liftRawKey ShelleyKeyS walletRootKey)
        index

    walletPolicyKeyHashBytes :: BS.ByteString
    walletPolicyKeyHashBytes = CA.digest $ snd walletPolicyData

    goldenPolicyKeyHashBytes :: BS.ByteString
    goldenPolicyKeyHashBytes =
      unsafeFromHex (T.encodeUtf8 goldenPolicyKeyHashHex)
  in
    walletPolicyKeyHashBytes `shouldBe` goldenPolicyKeyHashBytes

unit_scriptSlotIntervals
  :: Script KeyHash
  -> [Interval Natural]
  -> Expectation
unit_scriptSlotIntervals script interval =
  scriptSlotIntervals @KeyHash script `shouldBe` interval

unit_withinSlotInterval
  :: Script KeyHash
  -> (SlotNo, SlotNo)
  -> Bool
  -> Expectation
unit_withinSlotInterval script (from, to) expectation =
  withinSlotInterval from to (scriptSlotIntervals @KeyHash script)
    `shouldBe` expectation

goldenTestMnemonic :: Mnemonic 24
goldenTestMnemonic =
  unsafeMkMnemonic @24
    [ "history"
    , "stable"
    , "illegal"
    , "holiday"
    , "push"
    , "company"
    , "aisle"
    , "fly"
    , "check"
    , "dog"
    , "earn"
    , "admit"
    , "smart"
    , "rotate"
    , "nation"
    , "goddess"
    , "fix"
    , "wheat"
    , "scissors"
    , "across"
    , "crazy"
    , "actor"
    , "fence"
    , "baby"
    ]

instance Arbitrary XPrv where
  arbitrary = unsafeXPrv . BS.pack <$> vector 128

instance Arbitrary (Index 'Hardened 'PolicyK) where
  shrink _ = []
  arbitrary = arbitraryBoundedEnum