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 (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