bip39

BIP39 mnemonic codes in Haskell (docs.ppad.tech/bip39).
git clone git://git.ppad.tech/bip39.git
Log | Files | Refs | README | LICENSE

Main.hs (4303B)

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