{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
module Crypto.KDF.BIP39 (
mnemonic
, _mnemonic
, valid
, _valid
, seed
, _seed
, seed_unsafe
, Wordlist(..)
, english
, chinese_traditional
, chinese_simplified
, czech
, french
, korean
, italian
, japanese
, portuguese
, spanish
) where
import qualified Crypto.KDF.PBKDF as PBKDF
import qualified Crypto.Hash.SHA256 as SHA256
import qualified Crypto.Hash.SHA512 as SHA512
import Data.Bits ((.&.), (.|.), (.>>.), (.<<.))
import qualified Data.ByteString as BS
import qualified Data.ByteString.Internal as BI
import qualified Data.ByteString.Unsafe as BU
import qualified Data.Foldable as F
import qualified Data.Maybe as M
import qualified Data.Primitive.Array as PA
import Data.Word (Word64)
import qualified Data.List as L
import Prelude hiding (words)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.ICU.Normalize2 as ICU
import System.IO.Unsafe (unsafePerformIO)
fi :: (Integral a, Num b) => a -> b
fi :: forall a b. (Integral a, Num b) => a -> b
fi = a -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral
{-# INLINE fi #-}
newtype Wordlist = Wordlist (PA.Array T.Text)
mnemonic
:: BS.ByteString
-> T.Text
mnemonic :: ByteString -> Text
mnemonic = Wordlist -> ByteString -> Text
_mnemonic Wordlist
english
_mnemonic
:: Wordlist
-> BS.ByteString
-> T.Text
_mnemonic :: Wordlist -> ByteString -> Text
_mnemonic (Wordlist Array Text
wlist) entropy :: ByteString
entropy@(BI.PS ForeignPtr Word8
_ Int
_ Int
l)
| Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
16 = [Char] -> Text
forall a. HasCallStack => [Char] -> a
error [Char]
"ppad-bip39 (mnemonic): invalid entropy length"
| Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
32 = [Char] -> Text
forall a. HasCallStack => [Char] -> a
error [Char]
"ppad-bip39 (mnemonic): invalid entropy length"
| Bool
otherwise =
let has :: ByteString
has = ByteString -> ByteString
SHA256.hash ByteString
entropy
h :: Word8
h = ByteString -> Word8
BU.unsafeHead ByteString
has
n :: Int
n = Int
l Int -> Int -> Int
forall a. Integral a => a -> a -> a
`quot` Int
4
kek :: Word8
kek = Word8
h Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. (Word8
0b1111_1111 Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
.<<. (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n))
cat :: ByteString
cat = ByteString
entropy ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Word8 -> ByteString
BS.singleton Word8
kek
in Text -> [Text] -> Text
T.intercalate Text
" " (Array Text -> ByteString -> [Text]
words Array Text
wlist ByteString
cat)
{-# INLINE _mnemonic #-}
type Acc = (BS.ByteString, Word64, Int)
words :: PA.Array T.Text -> BS.ByteString -> [T.Text]
words :: Array Text -> ByteString -> [Text]
words Array Text
wlist ByteString
bs = (Acc -> Maybe (Text, Acc)) -> Acc -> [Text]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
L.unfoldr Acc -> Maybe (Text, Acc)
coalg (ByteString
bs, Word64
0, Int
0) where
mask :: Word64
mask = Word64
0b0111_1111_1111
coalg :: Acc -> Maybe (T.Text, Acc)
coalg :: Acc -> Maybe (Text, Acc)
coalg (ByteString
etc, Word64
acc, Int
len)
| Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10 =
let w11 :: Int
w11 = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fi ((Word64
acc Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
.>>. (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
11)) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
mask)
nacc :: Word64
nacc = Word64
acc Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. ((Word64
1 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
.<<. (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
11)) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
1)
nlen :: Int
nlen = Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
11
word :: Text
word = Array Text -> Int -> Text
forall a. Array a -> Int -> a
PA.indexArray Array Text
wlist Int
w11
in (Text, Acc) -> Maybe (Text, Acc)
forall a. a -> Maybe a
Just (Text
word, (ByteString
etc, Word64
nacc, Int
nlen))
| Bool -> Bool
not (ByteString -> Bool
BS.null ByteString
etc) =
let next :: Word8
next = ByteString -> Word8
BU.unsafeHead ByteString
etc
rest :: ByteString
rest = ByteString -> ByteString
BU.unsafeTail ByteString
etc
nacc :: Word64
nacc = (Word64
acc Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
.<<. Int
8) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fi Word8
next
nlen :: Int
nlen = Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
8
in Acc -> Maybe (Text, Acc)
coalg (ByteString
rest, Word64
nacc, Int
nlen)
| Bool
otherwise =
Maybe (Text, Acc)
forall a. Maybe a
Nothing
{-# INLINE words #-}
seed
:: T.Text
-> T.Text
-> BS.ByteString
seed :: Text -> Text -> ByteString
seed = Wordlist -> Text -> Text -> ByteString
_seed Wordlist
english
_seed
:: Wordlist
-> T.Text
-> T.Text
-> BS.ByteString
_seed :: Wordlist -> Text -> Text -> ByteString
_seed Wordlist
wlist Text
mnem Text
pass
| Bool -> Bool
not (Wordlist -> Text -> Bool
_valid Wordlist
wlist Text
mnem) =
[Char] -> ByteString
forall a. HasCallStack => [Char] -> a
error [Char]
"ppad-bip39 (seed): invalid mnemonic"
| Bool
otherwise =
let salt :: ByteString
salt = Text -> ByteString
TE.encodeUtf8 (Text
"mnemonic" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
ICU.nfkd Text
pass)
norm :: ByteString
norm = Text -> ByteString
TE.encodeUtf8 (Text -> Text
ICU.nfkd Text
mnem)
in (ByteString -> ByteString -> ByteString)
-> ByteString -> ByteString -> Word64 -> Word32 -> ByteString
PBKDF.derive ByteString -> ByteString -> ByteString
SHA512.hmac ByteString
norm ByteString
salt Word64
2048 Word32
64 where
{-# INLINE _seed #-}
seed_unsafe
:: T.Text
-> T.Text
-> BS.ByteString
seed_unsafe :: Text -> Text -> ByteString
seed_unsafe Text
mnem Text
pass
| [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Text -> [Text]
T.words Text
mnem) Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Int
12, Int
15, Int
18, Int
21, Int
24] =
[Char] -> ByteString
forall a. HasCallStack => [Char] -> a
error [Char]
"ppad-bip39 (seed_unsafe): invalid mnemonic"
| Bool
otherwise =
let salt :: ByteString
salt = Text -> ByteString
TE.encodeUtf8 (Text
"mnemonic" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
ICU.nfkd Text
pass)
norm :: ByteString
norm = Text -> ByteString
TE.encodeUtf8 (Text -> Text
ICU.nfkd Text
mnem)
in (ByteString -> ByteString -> ByteString)
-> ByteString -> ByteString -> Word64 -> Word32 -> ByteString
PBKDF.derive ByteString -> ByteString -> ByteString
SHA512.hmac ByteString
norm ByteString
salt Word64
2048 Word32
64 where
valid
:: T.Text
-> Bool
valid :: Text -> Bool
valid Text
mnem =
[Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
ws Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
12, Int
15, Int
18, Int
21, Int
24]
Bool -> Bool -> Bool
&& (Maybe Text -> Bool) -> [Maybe Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Maybe Text -> Bool
forall a. Maybe a -> Bool
M.isJust ((Text -> Maybe Text) -> [Text] -> [Maybe Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Text
word -> (Text -> Bool) -> Array Text -> Maybe Text
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
F.find (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
word) Array Text
wlist) [Text]
ws)
where
ws :: [Text]
ws = Text -> [Text]
T.words Text
mnem
Wordlist Array Text
wlist = Wordlist
english
_valid
:: Wordlist
-> T.Text
-> Bool
_valid :: Wordlist -> Text -> Bool
_valid (Wordlist Array Text
wlist) Text
mnem =
[Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
ws Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
12, Int
15, Int
18, Int
21, Int
24]
Bool -> Bool -> Bool
&& (Maybe Text -> Bool) -> [Maybe Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Maybe Text -> Bool
forall a. Maybe a -> Bool
M.isJust ((Text -> Maybe Text) -> [Text] -> [Maybe Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Text
word -> (Text -> Bool) -> Array Text -> Maybe Text
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
F.find (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
word) Array Text
wlist) [Text]
ws)
where
ws :: [Text]
ws = Text -> [Text]
T.words Text
mnem
english :: Wordlist
english :: Wordlist
english = IO Wordlist -> Wordlist
forall a. IO a -> a
unsafePerformIO (IO Wordlist -> Wordlist) -> IO Wordlist -> Wordlist
forall a b. (a -> b) -> a -> b
$ do
Text
wlist <- (ByteString -> Text) -> IO ByteString -> IO Text
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
TE.decodeUtf8 ([Char] -> IO ByteString
BS.readFile [Char]
"etc/english.txt")
let ls :: [Text]
ls = Text -> [Text]
T.lines Text
wlist
Wordlist -> IO Wordlist
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Array Text -> Wordlist
Wordlist ([Text] -> Array Text
forall a. [a] -> Array a
PA.arrayFromList [Text]
ls))
{-# NOINLINE english #-}
chinese_traditional :: Wordlist
chinese_traditional :: Wordlist
chinese_traditional = IO Wordlist -> Wordlist
forall a. IO a -> a
unsafePerformIO (IO Wordlist -> Wordlist) -> IO Wordlist -> Wordlist
forall a b. (a -> b) -> a -> b
$ do
Text
wlist <- (ByteString -> Text) -> IO ByteString -> IO Text
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
TE.decodeUtf8 ([Char] -> IO ByteString
BS.readFile [Char]
"etc/chinese_traditional.txt")
let ls :: [Text]
ls = Text -> [Text]
T.lines Text
wlist
Wordlist -> IO Wordlist
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Array Text -> Wordlist
Wordlist ([Text] -> Array Text
forall a. [a] -> Array a
PA.arrayFromList [Text]
ls))
{-# NOINLINE chinese_traditional #-}
chinese_simplified :: Wordlist
chinese_simplified :: Wordlist
chinese_simplified = IO Wordlist -> Wordlist
forall a. IO a -> a
unsafePerformIO (IO Wordlist -> Wordlist) -> IO Wordlist -> Wordlist
forall a b. (a -> b) -> a -> b
$ do
Text
wlist <- (ByteString -> Text) -> IO ByteString -> IO Text
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
TE.decodeUtf8 ([Char] -> IO ByteString
BS.readFile [Char]
"etc/chinese_simplified.txt")
let ls :: [Text]
ls = Text -> [Text]
T.lines Text
wlist
Wordlist -> IO Wordlist
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Array Text -> Wordlist
Wordlist ([Text] -> Array Text
forall a. [a] -> Array a
PA.arrayFromList [Text]
ls))
{-# NOINLINE chinese_simplified #-}
korean :: Wordlist
korean :: Wordlist
korean = IO Wordlist -> Wordlist
forall a. IO a -> a
unsafePerformIO (IO Wordlist -> Wordlist) -> IO Wordlist -> Wordlist
forall a b. (a -> b) -> a -> b
$ do
Text
wlist <- (ByteString -> Text) -> IO ByteString -> IO Text
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
TE.decodeUtf8 ([Char] -> IO ByteString
BS.readFile [Char]
"etc/korean.txt")
let ls :: [Text]
ls = Text -> [Text]
T.lines Text
wlist
Wordlist -> IO Wordlist
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Array Text -> Wordlist
Wordlist ([Text] -> Array Text
forall a. [a] -> Array a
PA.arrayFromList [Text]
ls))
{-# NOINLINE korean #-}
french :: Wordlist
french :: Wordlist
french = IO Wordlist -> Wordlist
forall a. IO a -> a
unsafePerformIO (IO Wordlist -> Wordlist) -> IO Wordlist -> Wordlist
forall a b. (a -> b) -> a -> b
$ do
Text
wlist <- (ByteString -> Text) -> IO ByteString -> IO Text
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
TE.decodeUtf8 ([Char] -> IO ByteString
BS.readFile [Char]
"etc/french.txt")
let ls :: [Text]
ls = Text -> [Text]
T.lines Text
wlist
Wordlist -> IO Wordlist
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Array Text -> Wordlist
Wordlist ([Text] -> Array Text
forall a. [a] -> Array a
PA.arrayFromList [Text]
ls))
{-# NOINLINE french #-}
spanish :: Wordlist
spanish :: Wordlist
spanish = IO Wordlist -> Wordlist
forall a. IO a -> a
unsafePerformIO (IO Wordlist -> Wordlist) -> IO Wordlist -> Wordlist
forall a b. (a -> b) -> a -> b
$ do
Text
wlist <- (ByteString -> Text) -> IO ByteString -> IO Text
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
TE.decodeUtf8 ([Char] -> IO ByteString
BS.readFile [Char]
"etc/spanish.txt")
let ls :: [Text]
ls = Text -> [Text]
T.lines Text
wlist
Wordlist -> IO Wordlist
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Array Text -> Wordlist
Wordlist ([Text] -> Array Text
forall a. [a] -> Array a
PA.arrayFromList [Text]
ls))
{-# NOINLINE spanish #-}
czech :: Wordlist
czech :: Wordlist
czech = IO Wordlist -> Wordlist
forall a. IO a -> a
unsafePerformIO (IO Wordlist -> Wordlist) -> IO Wordlist -> Wordlist
forall a b. (a -> b) -> a -> b
$ do
Text
wlist <- (ByteString -> Text) -> IO ByteString -> IO Text
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
TE.decodeUtf8 ([Char] -> IO ByteString
BS.readFile [Char]
"etc/czech.txt")
let ls :: [Text]
ls = Text -> [Text]
T.lines Text
wlist
Wordlist -> IO Wordlist
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Array Text -> Wordlist
Wordlist ([Text] -> Array Text
forall a. [a] -> Array a
PA.arrayFromList [Text]
ls))
{-# NOINLINE czech #-}
italian :: Wordlist
italian :: Wordlist
italian = IO Wordlist -> Wordlist
forall a. IO a -> a
unsafePerformIO (IO Wordlist -> Wordlist) -> IO Wordlist -> Wordlist
forall a b. (a -> b) -> a -> b
$ do
Text
wlist <- (ByteString -> Text) -> IO ByteString -> IO Text
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
TE.decodeUtf8 ([Char] -> IO ByteString
BS.readFile [Char]
"etc/italian.txt")
let ls :: [Text]
ls = Text -> [Text]
T.lines Text
wlist
Wordlist -> IO Wordlist
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Array Text -> Wordlist
Wordlist ([Text] -> Array Text
forall a. [a] -> Array a
PA.arrayFromList [Text]
ls))
{-# NOINLINE italian #-}
portuguese :: Wordlist
portuguese :: Wordlist
portuguese = IO Wordlist -> Wordlist
forall a. IO a -> a
unsafePerformIO (IO Wordlist -> Wordlist) -> IO Wordlist -> Wordlist
forall a b. (a -> b) -> a -> b
$ do
Text
wlist <- (ByteString -> Text) -> IO ByteString -> IO Text
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
TE.decodeUtf8 ([Char] -> IO ByteString
BS.readFile [Char]
"etc/portuguese.txt")
let ls :: [Text]
ls = Text -> [Text]
T.lines Text
wlist
Wordlist -> IO Wordlist
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Array Text -> Wordlist
Wordlist ([Text] -> Array Text
forall a. [a] -> Array a
PA.arrayFromList [Text]
ls))
{-# NOINLINE portuguese #-}
japanese :: Wordlist
japanese :: Wordlist
japanese = IO Wordlist -> Wordlist
forall a. IO a -> a
unsafePerformIO (IO Wordlist -> Wordlist) -> IO Wordlist -> Wordlist
forall a b. (a -> b) -> a -> b
$ do
Text
wlist <- (ByteString -> Text) -> IO ByteString -> IO Text
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
TE.decodeUtf8 ([Char] -> IO ByteString
BS.readFile [Char]
"etc/japanese.txt")
let ls :: [Text]
ls = Text -> [Text]
T.lines Text
wlist
Wordlist -> IO Wordlist
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Array Text -> Wordlist
Wordlist ([Text] -> Array Text
forall a. [a] -> Array a
PA.arrayFromList [Text]
ls))
{-# NOINLINE japanese #-}