Main.hs (4257B)
1 {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} 2 {-# LANGUAGE OverloadedStrings #-} 3 {-# LANGUAGE RecordWildCards #-} 4 5 module Main where 6 7 import qualified Crypto.HDKey.BIP32 as BIP32 8 import qualified Crypto.KDF.BIP39 as BIP39 9 import qualified Data.Aeson as A 10 import qualified Data.Text.ICU.Normalize2 as ICU 11 import qualified Data.Text.IO as TIO 12 import Test.Tasty 13 import Test.Tasty.HUnit 14 import qualified Vectors as V 15 16 data Wordlist = 17 English 18 | ChineseTraditional 19 | ChineseSimplified 20 | Czech 21 | French 22 | Italian 23 | Japanese 24 | Korean 25 | Portuguese 26 | Spanish 27 28 main :: IO () 29 main = do 30 vectors_bip39 <- TIO.readFile "etc/vectors.json" 31 vectors_jp_bip39 <- TIO.readFile "etc/test_JP_BIP39.json" 32 let vectors = do 33 a <- A.decodeStrictText vectors_bip39 :: Maybe V.Vectors 34 b <- A.decodeStrictText vectors_jp_bip39 :: Maybe [V.JPBip39Test] 35 pure (a, b) 36 case vectors of 37 Nothing -> error "couldn't parse bip39 vectors" 38 Just (vs, js) -> defaultMain $ 39 testGroup "ppad-bip39" [ 40 bip39_tests vs 41 , jp_bip39_tests js 42 ] 43 44 jp_bip39_tests :: [V.JPBip39Test] -> TestTree 45 jp_bip39_tests jp_vectors = 46 testGroup "jp bip39 vectors" (fmap execute_jp jp_vectors) 47 48 bip39_tests :: V.Vectors -> TestTree 49 bip39_tests V.Vectors {..} = 50 testGroup "bip39 vectors" [ 51 testGroup "english" 52 (fmap (execute English) v_english) 53 , testGroup "chinese_traditional" 54 (fmap (execute ChineseTraditional) v_chinese_traditional) 55 , testGroup "chinese_simplified" 56 (fmap (execute ChineseSimplified) v_chinese_simplified) 57 , testGroup "french" 58 (fmap (execute French) v_french) 59 , testGroup "czech" 60 (fmap (execute Czech) v_czech) 61 , testGroup "italian" 62 (fmap (execute Italian) v_italian) 63 , testGroup "japanese" 64 (fmap (execute Japanese) v_japanese) 65 , testGroup "korean" 66 (fmap (execute Korean) v_korean) 67 , testGroup "portuguese" 68 (fmap (execute Portuguese) v_portuguese) 69 , testGroup "spanish" 70 (fmap (execute Spanish) v_spanish) 71 ] 72 73 execute :: Wordlist -> V.Bip39Test -> TestTree 74 execute wlist V.Bip39Test {..} = do 75 let entr = bt_entropy 76 mnem = bt_mnemonic 77 seed = bt_seed 78 xprv = bt_xprv 79 Just out_mnem = BIP39._mnemonic wl entr 80 Just giv_seed = seed_fn mnem "TREZOR" 81 Just out_seed = seed_fn out_mnem "TREZOR" 82 Just out_xprv = BIP32.master out_seed >>= BIP32.xprv 83 t_msg = mempty 84 testGroup t_msg [ 85 -- we always output (NFKD) normalized UTF8, but test inputs may not be 86 -- normalized in this fashion 87 testCase "mnemonic" $ assertEqual mempty (ICU.nfkd mnem) out_mnem 88 -- testing from the given mnemonic ensures we're normalizing properly 89 -- before seed calculation 90 , testCase "seed (from given mnemonic)" $ assertEqual mempty seed giv_seed 91 , testCase "seed (from derived mnemonic)" $ assertEqual mempty seed out_seed 92 , testCase "xprv" $ assertEqual mempty xprv out_xprv 93 ] 94 where 95 seed_fn = case wlist of 96 English -> BIP39.seed 97 _ -> BIP39.seed_unsafe 98 wl = case wlist of 99 English -> BIP39.english 100 ChineseTraditional -> BIP39.chinese_traditional 101 ChineseSimplified -> BIP39.chinese_simplified 102 Czech -> BIP39.czech 103 French -> BIP39.french 104 Italian -> BIP39.italian 105 Japanese -> BIP39.japanese 106 Korean -> BIP39.korean 107 Portuguese -> BIP39.portuguese 108 Spanish -> BIP39.spanish 109 110 execute_jp :: V.JPBip39Test -> TestTree 111 execute_jp V.JPBip39Test {..} = do 112 let entr = jp_entropy 113 mnem = jp_mnemonic 114 pass = jp_passphrase 115 seed = jp_seed 116 xprv = jp_xprv 117 Just out_mnem = BIP39._mnemonic BIP39.japanese entr 118 Just giv_seed = BIP39.seed_unsafe mnem pass 119 Just out_seed = BIP39.seed_unsafe out_mnem pass 120 Just out_xprv = BIP32.master out_seed >>= BIP32.xprv 121 testGroup mempty [ 122 testCase "mnemonic" $ assertEqual mempty (ICU.nfkd mnem) out_mnem 123 , testCase "seed (from given mnemonic)" $ assertEqual mempty seed giv_seed 124 , testCase "seed (from derived mnemonic)" $ assertEqual mempty seed out_seed 125 , testCase "xprv" $ assertEqual mempty xprv out_xprv 126 ] 127