{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeFamilies #-}
module Main (main) where
import Basement.Nat
import qualified Basement.Sized.List as LN
import Foundation
import Foundation.Check
import qualified Foundation.Parser as Parser
import Foundation.Collection ((!), nonEmpty_)
import Foundation.String
import Foundation.String.Read (readIntegral)
import Data.List (elemIndex)
import Control.Arrow (left)
import Inspector
import qualified Inspector.TestVector.Types as Type
import qualified Inspector.TestVector.Value as Value
import Data.ByteArray (Bytes, convert)
import qualified Data.ByteArray as B
import Cardano.Crypto.Wallet
import Cardano.Crypto.Encoding.Seed
import Cardano.Crypto.Encoding.BIP39
import Crypto.Encoding.BIP39.English (english)
import Cardano.Internal.Compat (fromRight)
import Test.Orphans
main :: IO ()
main = defaultTest $ do
goldenSignatureEd25519
goldenBIP39
goldenHDWallet
goldenPaperwallet
-- -------------------------------------------------------------------------- --
type GoldenPaperWallet n
= "cardano" :> "crypto" :> PathParameter "scramble" n
:> Payload "iv" ScrambleIV
:> Payload "input" (Mnemonic 'English (MnemonicWords n))
:> Payload "passphrase" Passphrase
:> Payload "shielded_input" (Mnemonic 'English (MnemonicWords (n + IVSizeBits)))
goldenPaperwallet :: GoldenT ()
goldenPaperwallet = group $ do
golden (Proxy :: Proxy (GoldenPaperWallet 128)) $ \iv (Mnemonic input) pw ->
Mnemonic (scrambleMnemonic (Proxy @128) iv input pw)
golden (Proxy :: Proxy (GoldenPaperWallet 160)) $ \iv (Mnemonic input) pw ->
Mnemonic (scrambleMnemonic (Proxy @160) iv input pw)
golden (Proxy :: Proxy (GoldenPaperWallet 192)) $ \iv (Mnemonic input) pw ->
Mnemonic (scrambleMnemonic (Proxy @192) iv input pw)
-- -------------------------------------------------------------------------- --
type HDWallet n
= "cardano" :> "crypto" :> "wallet" :> PathParameter "BIP39-" n
:> Payload "words" (Mnemonic 'English (MnemonicWords n))
:> Payload "passphrase" Passphrase
:> Payload "master_key_generation" MasterKeyGeneration
:> Payload "derivation_scheme" DerivationScheme
:> Payload "path" ChainCodePath
:> Payload "data_to_sign" String
:> ( Payload "xPub" XPub
, Payload "xPriv" XPrv
, Payload "signature" XSignature
, Payload "seed" Seed
)
goldenHDWallet :: GoldenT ()
goldenHDWallet = group $ do
summary "This test vectors uses the `Cardano.Crypto.Wallet` primitives to produce extended\n\
\private keys which are _encrypted_ with a passphrase. A passphrase can be empty as well.\n\
\Under this schema, we support only hardened key derivation."
golden (Proxy :: Proxy (HDWallet 128)) (runTest (Proxy @128))
golden (Proxy :: Proxy (HDWallet 160)) (runTest (Proxy @160))
golden (Proxy :: Proxy (HDWallet 192)) (runTest (Proxy @192))
golden (Proxy :: Proxy (HDWallet 224)) (runTest (Proxy @224))
golden (Proxy :: Proxy (HDWallet 256)) (runTest (Proxy @256))
where
runTest :: forall n csz mw . ConsistentEntropy n mw csz
=> Proxy n
-> Mnemonic 'English mw
-> Passphrase
-> MasterKeyGeneration
-> DerivationScheme
-> ChainCodePath
-> String
-> (XPub, XPrv, XSignature, Seed)
runTest p (Mnemonic mw) pw mkg ds (Root path) toSign =
let -- 1. retrieve the seed
-- 1. retrieve the seed and 2. generate from the seed
(seed, master) = case mkg of
MasterKeyRetryOld ->
let seedX = fromMaybe (error "Invalid Mnemonic, cannot retrieve the `Seed'")
(cardanoSlSeed p mw)
in (seedX, generate seedX pw)
MasterKeyPBKDF ->
let seedX = seedFromMnemonics p mw
in (seedX, generateNew seedX (B.empty :: Bytes) pw)
-- 3. get the XPrv from the master and the path
priv = deriveWith master path
-- 4. get the public key
pub = toXPub priv
-- 5. sign some data
s = sign pw priv toSign
in (pub, priv, s, seed)
where
deriveWith :: XPrv -> [Word32] -> XPrv
deriveWith = foldl' (deriveXPrv ds pw)
seedFromMnemonics :: forall n csz mw . ConsistentEntropy n mw csz
=> Proxy n
-> MnemonicSentence mw
-> Seed
seedFromMnemonics _ mw =
case wordsToEntropy @n @csz @mw mw of
Left _ -> error "Invalid Mnemonic"
Right e -> B.convert $ entropyRaw e
-- -------------------------------------------------------------------------- --
type BIP39 n
= "crypto" :> "encoding" :> PathParameter "BIP39-" n
:> Payload "words" (Mnemonic 'English (MnemonicWords n))
:> Payload "passphrase" Passphrase
:> ( Payload "entropy" (Entropy n)
, Payload "seed" Seed
)
goldenBIP39 :: GoldenT ()
goldenBIP39 = group $ do
summary "Test official BIP39"
golden (Proxy :: Proxy (BIP39 128)) (runTest (Proxy @128))
-- golden (Proxy :: Proxy (BIP39 160)) (runTest (Proxy @160))
golden (Proxy :: Proxy (BIP39 192)) (runTest (Proxy @192))
-- golden (Proxy :: Proxy (BIP39 224)) (runTest (Proxy @224))
golden (Proxy :: Proxy (BIP39 256)) (runTest (Proxy @256))
where
runTest :: forall n csz mw . ConsistentEntropy n mw csz
=> Proxy n
-> Mnemonic 'English mw
-> Passphrase
-> (Entropy n, Seed)
runTest p (Mnemonic mw) pw =
let -- 1. retrieve the entroy
entropy = fromRight (error "invalid mnemonic phrase")
(wordsToEntropy @n mw)
-- 2. retrieve the seed
seed = sentenceToSeed @mw mw english pw
in (entropy, seed)
-- -------------------------------------------------------------------------- --
type SignatureEd25519
= "cardano" :> "crypto" :> "signature-ed25519"
:> Payload "xpub" XPub
:> Payload "data" Bytes
:> Payload "signature" XSignature
:> Payload "valid" Bool
goldenSignatureEd25519 :: GoldenT ()
goldenSignatureEd25519 = golden (Proxy :: Proxy SignatureEd25519) verify
-- -------------------------------------------------------------------------- --
-- Helpers --
-- -------------------------------------------------------------------------- --
-- | `m/0'/1'/1000'`
newtype ChainCodePath = Root [Word32]
deriving (Show, Eq, Typeable)
instance Arbitrary ChainCodePath where
arbitrary = Root <$> arbitrary
instance Inspectable ChainCodePath where
documentation _ = "Derivation Chain code path: list of derivation path."
exportType _ = Type.Array $ Type.UnsizedArray Type.Unsigned32
builder (Root l) = builder l
parser v = Root <$> parser v
-- Enum for the support language to read/write from mnemonic
data Language = English
-- | a convenient type to help read/parse/document expected input of type
-- BIP39 mnemonics
newtype Mnemonic (k :: Language) n = Mnemonic (MnemonicSentence n)
deriving (Eq, Typeable)
-- | The type of master key generation
data MasterKeyGeneration = MasterKeyRetryOld | MasterKeyPBKDF
deriving (Show,Eq)
instance Inspectable MasterKeyGeneration where
documentation _ = "Master Key Derivation: list of derivation path."
exportType _ = Type.String
builder MasterKeyRetryOld = Value.String "retry-old"
builder MasterKeyPBKDF = Value.String "pbkdf"
parser = withString "MasterKeyGeneration" $ \str -> case str of
"retry-old" -> pure MasterKeyRetryOld
"pbkdf" -> pure MasterKeyPBKDF
_ -> Left $ "Expected either `retry-old' or `pbkdf' but found: `" <> str <> "'"
instance Arbitrary MasterKeyGeneration where
arbitrary = elements $ nonEmpty_ [MasterKeyRetryOld, MasterKeyPBKDF]
instance Arbitrary (Mnemonic 'English 12) where
arbitrary = Mnemonic . entropyToWords @128 @4 @12 <$> arbitrary
instance Arbitrary (Mnemonic 'English 15) where
arbitrary = Mnemonic . entropyToWords @160 @5 @15 <$> arbitrary
instance Arbitrary (Mnemonic 'English 18) where
arbitrary = Mnemonic . entropyToWords @192 @6 @18 <$> arbitrary
instance Arbitrary (Mnemonic 'English 21) where
arbitrary = Mnemonic . entropyToWords @224 @7 @21 <$> arbitrary
instance Arbitrary (Mnemonic 'English 24) where
arbitrary = Mnemonic . entropyToWords @256 @8 @24 <$> arbitrary
instance ValidMnemonicSentence n => Inspectable (Mnemonic 'English n) where
documentation _ = "BIP39 mnemonic sentence (in English) of " <> show n <> " BIP39 Enlighs words"
where
n = natVal @n Proxy
exportType _ = Type.String
builder (Mnemonic l) = Value.String $ mnemonicSentenceToString english l
parser v = do
strs <- words <$> parser v
phrase <- left show $ mnemonicPhrase @n strs
left show $ Mnemonic <$> mnemonicPhraseToMnemonicSentence english phrase
where
n = natVal @n Proxy
instance Arbitrary XSignature where
arbitrary = undefined
instance Arbitrary Bytes where
arbitrary = undefined
instance Arbitrary XPub where
arbitrary = undefined