{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_HADDOCK prune #-}
module Cardano.Mnemonic
(
SomeMnemonic(..)
, MkSomeMnemonic (..)
, MkSomeMnemonicError(..)
, someMnemonicToBytes
, NatVals (..)
, Mnemonic
, mkMnemonic
, MkMnemonicError(..)
, mnemonicToText
, mnemonicToEntropy
, Entropy
, genEntropy
, mkEntropy
, entropyToBytes
, entropyToMnemonic
, EntropyError(..)
, DictionaryError(..)
, MnemonicWordsError(..)
, ValidEntropySize
, ValidChecksumSize
, ValidMnemonicSentence
, ConsistentEntropy
, CheckSumBits
, EntropySize
, MnemonicWords
, MnemonicException(..)
) where
import Prelude
import Basement.NormalForm
( NormalForm (..) )
import Basement.Sized.List
( unListN )
import Control.Arrow
( left )
import Control.DeepSeq
( NFData (..) )
import Control.Monad.Catch
( throwM )
import Crypto.Encoding.BIP39
( CheckSumBits
, ConsistentEntropy
, DictionaryError (..)
, Entropy
, EntropyError (..)
, EntropySize
, MnemonicSentence
, MnemonicWords
, MnemonicWordsError (..)
, ValidChecksumSize
, ValidEntropySize
, ValidMnemonicSentence
, dictionaryIndexToWord
, entropyRaw
, entropyToWords
, mnemonicPhrase
, mnemonicPhraseToMnemonicSentence
, mnemonicSentenceToListN
, toEntropy
, wordsToEntropy
)
import Data.Bifunctor
( bimap )
import Data.ByteArray
( ScrubbedBytes )
import Data.List
( intercalate )
import Data.Proxy
( Proxy (..) )
import Data.Text
( Text )
import Data.Type.Equality
( (:~:) (..), testEquality )
import Data.Typeable
( Typeable )
import GHC.TypeLits
( KnownNat, Nat, natVal )
import Type.Reflection
( typeOf )
import qualified Basement.Compat.Base as Basement
import qualified Basement.String as Basement
import qualified Crypto.Encoding.BIP39.English as Dictionary
import qualified Crypto.Random.Entropy as Crypto
import qualified Data.ByteArray as BA
import qualified Data.Text as T
data Mnemonic (mw :: Nat) = Mnemonic
{ Mnemonic mw -> Entropy (EntropySize mw)
mnemonicToEntropy :: Entropy (EntropySize mw)
, Mnemonic mw -> MnemonicSentence mw
mnemonicToSentence :: MnemonicSentence mw
} deriving stock (Mnemonic mw -> Mnemonic mw -> Bool
(Mnemonic mw -> Mnemonic mw -> Bool)
-> (Mnemonic mw -> Mnemonic mw -> Bool) -> Eq (Mnemonic mw)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (mw :: Nat). Mnemonic mw -> Mnemonic mw -> Bool
/= :: Mnemonic mw -> Mnemonic mw -> Bool
$c/= :: forall (mw :: Nat). Mnemonic mw -> Mnemonic mw -> Bool
== :: Mnemonic mw -> Mnemonic mw -> Bool
$c== :: forall (mw :: Nat). Mnemonic mw -> Mnemonic mw -> Bool
Eq, Int -> Mnemonic mw -> ShowS
[Mnemonic mw] -> ShowS
Mnemonic mw -> String
(Int -> Mnemonic mw -> ShowS)
-> (Mnemonic mw -> String)
-> ([Mnemonic mw] -> ShowS)
-> Show (Mnemonic mw)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (mw :: Nat). Int -> Mnemonic mw -> ShowS
forall (mw :: Nat). [Mnemonic mw] -> ShowS
forall (mw :: Nat). Mnemonic mw -> String
showList :: [Mnemonic mw] -> ShowS
$cshowList :: forall (mw :: Nat). [Mnemonic mw] -> ShowS
show :: Mnemonic mw -> String
$cshow :: forall (mw :: Nat). Mnemonic mw -> String
showsPrec :: Int -> Mnemonic mw -> ShowS
$cshowsPrec :: forall (mw :: Nat). Int -> Mnemonic mw -> ShowS
Show)
newtype MnemonicException csz =
UnexpectedEntropyError (EntropyError csz)
deriving stock (Int -> MnemonicException csz -> ShowS
[MnemonicException csz] -> ShowS
MnemonicException csz -> String
(Int -> MnemonicException csz -> ShowS)
-> (MnemonicException csz -> String)
-> ([MnemonicException csz] -> ShowS)
-> Show (MnemonicException csz)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (csz :: Nat). Int -> MnemonicException csz -> ShowS
forall (csz :: Nat). [MnemonicException csz] -> ShowS
forall (csz :: Nat). MnemonicException csz -> String
showList :: [MnemonicException csz] -> ShowS
$cshowList :: forall (csz :: Nat). [MnemonicException csz] -> ShowS
show :: MnemonicException csz -> String
$cshow :: forall (csz :: Nat). MnemonicException csz -> String
showsPrec :: Int -> MnemonicException csz -> ShowS
$cshowsPrec :: forall (csz :: Nat). Int -> MnemonicException csz -> ShowS
Show, Typeable)
deriving newtype MnemonicException csz -> ()
(MnemonicException csz -> ()) -> NFData (MnemonicException csz)
forall a. (a -> ()) -> NFData a
forall (csz :: Nat). MnemonicException csz -> ()
rnf :: MnemonicException csz -> ()
$crnf :: forall (csz :: Nat). MnemonicException csz -> ()
NFData
data MkMnemonicError csz
= ErrMnemonicWords MnemonicWordsError
| ErrEntropy (EntropyError csz)
| ErrDictionary DictionaryError
deriving stock (MkMnemonicError csz -> MkMnemonicError csz -> Bool
(MkMnemonicError csz -> MkMnemonicError csz -> Bool)
-> (MkMnemonicError csz -> MkMnemonicError csz -> Bool)
-> Eq (MkMnemonicError csz)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (csz :: Nat).
MkMnemonicError csz -> MkMnemonicError csz -> Bool
/= :: MkMnemonicError csz -> MkMnemonicError csz -> Bool
$c/= :: forall (csz :: Nat).
MkMnemonicError csz -> MkMnemonicError csz -> Bool
== :: MkMnemonicError csz -> MkMnemonicError csz -> Bool
$c== :: forall (csz :: Nat).
MkMnemonicError csz -> MkMnemonicError csz -> Bool
Eq, Int -> MkMnemonicError csz -> ShowS
[MkMnemonicError csz] -> ShowS
MkMnemonicError csz -> String
(Int -> MkMnemonicError csz -> ShowS)
-> (MkMnemonicError csz -> String)
-> ([MkMnemonicError csz] -> ShowS)
-> Show (MkMnemonicError csz)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (csz :: Nat). Int -> MkMnemonicError csz -> ShowS
forall (csz :: Nat). [MkMnemonicError csz] -> ShowS
forall (csz :: Nat). MkMnemonicError csz -> String
showList :: [MkMnemonicError csz] -> ShowS
$cshowList :: forall (csz :: Nat). [MkMnemonicError csz] -> ShowS
show :: MkMnemonicError csz -> String
$cshow :: forall (csz :: Nat). MkMnemonicError csz -> String
showsPrec :: Int -> MkMnemonicError csz -> ShowS
$cshowsPrec :: forall (csz :: Nat). Int -> MkMnemonicError csz -> ShowS
Show)
deriving instance Eq (EntropyError czs)
deriving instance Eq MnemonicWordsError
deriving instance Eq DictionaryError
instance NFData (Mnemonic mw) where
rnf :: Mnemonic mw -> ()
rnf (Mnemonic Entropy (EntropySize mw)
ent MnemonicSentence mw
ws) = Entropy (EntropySize mw) -> ()
forall a. NormalForm a => a -> ()
toNormalForm Entropy (EntropySize mw)
ent () -> () -> ()
`seq` MnemonicSentence mw -> ()
forall a. NormalForm a => a -> ()
toNormalForm MnemonicSentence mw
ws
instance NFData (EntropyError csz) where
rnf :: EntropyError csz -> ()
rnf (ErrInvalidEntropyLength Int
a Int
b) = Int -> ()
forall a. NFData a => a -> ()
rnf Int
a () -> () -> ()
`seq` Int -> ()
forall a. NFData a => a -> ()
rnf Int
b
rnf (ErrInvalidEntropyChecksum Checksum csz
a Checksum csz
b) = Checksum csz -> ()
forall a. NormalForm a => a -> ()
toNormalForm Checksum csz
a () -> () -> ()
`seq` Checksum csz -> ()
forall a. NormalForm a => a -> ()
toNormalForm Checksum csz
b
instance NFData MnemonicWordsError where
rnf :: MnemonicWordsError -> ()
rnf (ErrWrongNumberOfWords Int
a Int
b) = Int -> ()
forall a. NFData a => a -> ()
rnf Int
a () -> () -> ()
`seq` Int -> ()
forall a. NFData a => a -> ()
rnf Int
b
instance NFData DictionaryError where
rnf :: DictionaryError -> ()
rnf (ErrInvalidDictionaryWord String
s) = String -> ()
forall a. NormalForm a => a -> ()
toNormalForm String
s
instance NFData (MkMnemonicError csz) where
rnf :: MkMnemonicError csz -> ()
rnf (ErrMnemonicWords MnemonicWordsError
e) = MnemonicWordsError -> ()
forall a. NFData a => a -> ()
rnf MnemonicWordsError
e
rnf (ErrEntropy EntropyError csz
e) = EntropyError csz -> ()
forall a. NFData a => a -> ()
rnf EntropyError csz
e
rnf (ErrDictionary DictionaryError
e) = DictionaryError -> ()
forall a. NFData a => a -> ()
rnf DictionaryError
e
mkEntropy
:: forall (ent :: Nat) csz. (ValidEntropySize ent, ValidChecksumSize ent csz)
=> ScrubbedBytes
-> Either (EntropyError csz) (Entropy ent)
mkEntropy :: ScrubbedBytes -> Either (EntropyError csz) (Entropy ent)
mkEntropy = ScrubbedBytes -> Either (EntropyError csz) (Entropy ent)
forall (n :: Nat) (csz :: Nat) ba.
(ValidEntropySize n, ValidChecksumSize n csz,
ByteArrayAccess ba) =>
ba -> Either (EntropyError csz) (Entropy n)
toEntropy
genEntropy
:: forall (ent :: Nat) csz. (ValidEntropySize ent, ValidChecksumSize ent csz)
=> IO (Entropy ent)
genEntropy :: IO (Entropy ent)
genEntropy =
let
size :: Int
size =
Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Proxy ent -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal @ent Proxy ent
forall k (t :: k). Proxy t
Proxy
eitherToIO :: Either (EntropyError csz) a -> IO a
eitherToIO =
(EntropyError csz -> IO a)
-> (a -> IO a) -> Either (EntropyError csz) a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (MnemonicException csz -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (MnemonicException csz -> IO a)
-> (EntropyError csz -> MnemonicException csz)
-> EntropyError csz
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntropyError csz -> MnemonicException csz
forall (csz :: Nat). EntropyError csz -> MnemonicException csz
UnexpectedEntropyError) a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
in
(Either (EntropyError csz) (Entropy ent) -> IO (Entropy ent)
forall a. Either (EntropyError csz) a -> IO a
eitherToIO (Either (EntropyError csz) (Entropy ent) -> IO (Entropy ent))
-> (ScrubbedBytes -> Either (EntropyError csz) (Entropy ent))
-> ScrubbedBytes
-> IO (Entropy ent)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScrubbedBytes -> Either (EntropyError csz) (Entropy ent)
forall (ent :: Nat) (csz :: Nat).
(ValidEntropySize ent, ValidChecksumSize ent csz) =>
ScrubbedBytes -> Either (EntropyError csz) (Entropy ent)
mkEntropy) (ScrubbedBytes -> IO (Entropy ent))
-> IO ScrubbedBytes -> IO (Entropy ent)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> IO ScrubbedBytes
forall byteArray. ByteArray byteArray => Int -> IO byteArray
Crypto.getEntropy (Int
size Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8)
mkMnemonic
:: forall (mw :: Nat) (ent :: Nat) csz.
( ConsistentEntropy ent mw csz
, EntropySize mw ~ ent
)
=> [Text]
-> Either (MkMnemonicError csz) (Mnemonic mw)
mkMnemonic :: [Text] -> Either (MkMnemonicError csz) (Mnemonic mw)
mkMnemonic [Text]
wordsm = do
MnemonicPhrase mw
phrase <- (MnemonicWordsError -> MkMnemonicError csz)
-> Either MnemonicWordsError (MnemonicPhrase mw)
-> Either (MkMnemonicError csz) (MnemonicPhrase mw)
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left MnemonicWordsError -> MkMnemonicError csz
forall (csz :: Nat). MnemonicWordsError -> MkMnemonicError csz
ErrMnemonicWords
(Either MnemonicWordsError (MnemonicPhrase mw)
-> Either (MkMnemonicError csz) (MnemonicPhrase mw))
-> Either MnemonicWordsError (MnemonicPhrase mw)
-> Either (MkMnemonicError csz) (MnemonicPhrase mw)
forall a b. (a -> b) -> a -> b
$ [String] -> Either MnemonicWordsError (MnemonicPhrase mw)
forall (mw :: Nat).
ValidMnemonicSentence mw =>
[String] -> Either MnemonicWordsError (MnemonicPhrase mw)
mnemonicPhrase @mw (Text -> String
toUtf8String (Text -> String) -> [Text] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
wordsm)
MnemonicSentence mw
sentence <- (DictionaryError -> MkMnemonicError csz)
-> Either DictionaryError (MnemonicSentence mw)
-> Either (MkMnemonicError csz) (MnemonicSentence mw)
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left DictionaryError -> MkMnemonicError csz
forall (csz :: Nat). DictionaryError -> MkMnemonicError csz
ErrDictionary
(Either DictionaryError (MnemonicSentence mw)
-> Either (MkMnemonicError csz) (MnemonicSentence mw))
-> Either DictionaryError (MnemonicSentence mw)
-> Either (MkMnemonicError csz) (MnemonicSentence mw)
forall a b. (a -> b) -> a -> b
$ Dictionary
-> MnemonicPhrase mw
-> Either DictionaryError (MnemonicSentence mw)
forall (mw :: Nat).
ValidMnemonicSentence mw =>
Dictionary
-> MnemonicPhrase mw
-> Either DictionaryError (MnemonicSentence mw)
mnemonicPhraseToMnemonicSentence Dictionary
Dictionary.english MnemonicPhrase mw
phrase
Entropy ent
entropy <- (EntropyError csz -> MkMnemonicError csz)
-> Either (EntropyError csz) (Entropy ent)
-> Either (MkMnemonicError csz) (Entropy ent)
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left EntropyError csz -> MkMnemonicError csz
forall (csz :: Nat). EntropyError csz -> MkMnemonicError csz
ErrEntropy
(Either (EntropyError csz) (Entropy ent)
-> Either (MkMnemonicError csz) (Entropy ent))
-> Either (EntropyError csz) (Entropy ent)
-> Either (MkMnemonicError csz) (Entropy ent)
forall a b. (a -> b) -> a -> b
$ MnemonicSentence mw -> Either (EntropyError csz) (Entropy ent)
forall (ent :: Nat) (csz :: Nat) (mw :: Nat).
ConsistentEntropy ent mw csz =>
MnemonicSentence mw -> Either (EntropyError csz) (Entropy ent)
wordsToEntropy MnemonicSentence mw
sentence
Mnemonic mw -> Either (MkMnemonicError csz) (Mnemonic mw)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Mnemonic :: forall (mw :: Nat).
Entropy (EntropySize mw) -> MnemonicSentence mw -> Mnemonic mw
Mnemonic
{ mnemonicToEntropy :: Entropy (EntropySize mw)
mnemonicToEntropy = Entropy ent
Entropy (EntropySize mw)
entropy
, mnemonicToSentence :: MnemonicSentence mw
mnemonicToSentence = MnemonicSentence mw
sentence
}
entropyToMnemonic
:: forall mw ent csz.
( ValidMnemonicSentence mw
, ValidEntropySize ent
, ValidChecksumSize ent csz
, ent ~ EntropySize mw
, mw ~ MnemonicWords ent
)
=> Entropy ent
-> Mnemonic mw
entropyToMnemonic :: Entropy ent -> Mnemonic mw
entropyToMnemonic Entropy ent
entropy = Mnemonic :: forall (mw :: Nat).
Entropy (EntropySize mw) -> MnemonicSentence mw -> Mnemonic mw
Mnemonic
{ mnemonicToSentence :: MnemonicSentence mw
mnemonicToSentence = Entropy ent -> MnemonicSentence mw
forall (n :: Nat) (csz :: Nat) (mw :: Nat).
ConsistentEntropy n mw csz =>
Entropy n -> MnemonicSentence mw
entropyToWords Entropy ent
entropy
, mnemonicToEntropy :: Entropy (EntropySize mw)
mnemonicToEntropy = Entropy ent
Entropy (EntropySize mw)
entropy
}
entropyToBytes
:: Entropy n
-> ScrubbedBytes
entropyToBytes :: Entropy n -> ScrubbedBytes
entropyToBytes = ByteString -> ScrubbedBytes
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (ByteString -> ScrubbedBytes)
-> (Entropy n -> ByteString) -> Entropy n -> ScrubbedBytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entropy n -> ByteString
forall (n :: Nat). Entropy n -> ByteString
entropyRaw
toUtf8String
:: Text
-> Basement.String
toUtf8String :: Text -> String
toUtf8String = String -> String
forall a. IsString a => String -> a
Basement.fromString (String -> String) -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
fromUtf8String
:: Basement.String
-> Text
fromUtf8String :: String -> Text
fromUtf8String = String -> Text
T.pack (String -> Text) -> (String -> String) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall l. IsList l => l -> [Item l]
Basement.toList
instance (KnownNat csz) => Basement.Exception (MnemonicException csz)
mnemonicToText
:: Mnemonic mw
-> [Text]
mnemonicToText :: Mnemonic mw -> [Text]
mnemonicToText =
(WordIndex -> Text) -> [WordIndex] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
fromUtf8String (String -> Text) -> (WordIndex -> String) -> WordIndex -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dictionary -> WordIndex -> String
dictionaryIndexToWord Dictionary
Dictionary.english)
([WordIndex] -> [Text])
-> (Mnemonic mw -> [WordIndex]) -> Mnemonic mw -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ListN mw WordIndex -> [WordIndex]
forall (n :: Nat) a. ListN n a -> [a]
unListN
(ListN mw WordIndex -> [WordIndex])
-> (Mnemonic mw -> ListN mw WordIndex)
-> Mnemonic mw
-> [WordIndex]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MnemonicSentence mw -> ListN mw WordIndex
forall (mw :: Nat). MnemonicSentence mw -> ListN mw WordIndex
mnemonicSentenceToListN
(MnemonicSentence mw -> ListN mw WordIndex)
-> (Mnemonic mw -> MnemonicSentence mw)
-> Mnemonic mw
-> ListN mw WordIndex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mnemonic mw -> MnemonicSentence mw
forall (mw :: Nat). Mnemonic mw -> MnemonicSentence mw
mnemonicToSentence
someMnemonicToBytes :: SomeMnemonic -> ScrubbedBytes
someMnemonicToBytes :: SomeMnemonic -> ScrubbedBytes
someMnemonicToBytes (SomeMnemonic Mnemonic mw
mw) = Entropy (EntropySize mw) -> ScrubbedBytes
forall (n :: Nat). Entropy n -> ScrubbedBytes
entropyToBytes (Entropy (EntropySize mw) -> ScrubbedBytes)
-> Entropy (EntropySize mw) -> ScrubbedBytes
forall a b. (a -> b) -> a -> b
$ Mnemonic mw -> Entropy (EntropySize mw)
forall (mw :: Nat). Mnemonic mw -> Entropy (EntropySize mw)
mnemonicToEntropy Mnemonic mw
mw
data SomeMnemonic where
SomeMnemonic :: forall mw. KnownNat mw => Mnemonic mw -> SomeMnemonic
deriving instance Show SomeMnemonic
instance Eq SomeMnemonic where
(SomeMnemonic Mnemonic mw
mwa) == :: SomeMnemonic -> SomeMnemonic -> Bool
== (SomeMnemonic Mnemonic mw
mwb) =
case Mnemonic mw -> TypeRep (Mnemonic mw)
forall a. Typeable a => a -> TypeRep a
typeOf Mnemonic mw
mwa TypeRep (Mnemonic mw)
-> TypeRep (Mnemonic mw) -> Maybe (Mnemonic mw :~: Mnemonic mw)
forall k (f :: k -> *) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
`testEquality` Mnemonic mw -> TypeRep (Mnemonic mw)
forall a. Typeable a => a -> TypeRep a
typeOf Mnemonic mw
mwb of
Maybe (Mnemonic mw :~: Mnemonic mw)
Nothing -> Bool
False
Just Mnemonic mw :~: Mnemonic mw
Refl -> Mnemonic mw
mwa Mnemonic mw -> Mnemonic mw -> Bool
forall a. Eq a => a -> a -> Bool
== Mnemonic mw
Mnemonic mw
mwb
instance NFData SomeMnemonic where
rnf :: SomeMnemonic -> ()
rnf (SomeMnemonic Mnemonic mw
mnem) = Mnemonic mw -> ()
forall a. NFData a => a -> ()
rnf Mnemonic mw
mnem
class MkSomeMnemonic (sz :: [Nat]) where
mkSomeMnemonic :: [Text] -> Either (MkSomeMnemonicError sz) SomeMnemonic
newtype MkSomeMnemonicError (sz :: [Nat]) =
MkSomeMnemonicError { MkSomeMnemonicError sz -> String
getMkSomeMnemonicError :: String }
deriving stock (MkSomeMnemonicError sz -> MkSomeMnemonicError sz -> Bool
(MkSomeMnemonicError sz -> MkSomeMnemonicError sz -> Bool)
-> (MkSomeMnemonicError sz -> MkSomeMnemonicError sz -> Bool)
-> Eq (MkSomeMnemonicError sz)
forall (sz :: [Nat]).
MkSomeMnemonicError sz -> MkSomeMnemonicError sz -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MkSomeMnemonicError sz -> MkSomeMnemonicError sz -> Bool
$c/= :: forall (sz :: [Nat]).
MkSomeMnemonicError sz -> MkSomeMnemonicError sz -> Bool
== :: MkSomeMnemonicError sz -> MkSomeMnemonicError sz -> Bool
$c== :: forall (sz :: [Nat]).
MkSomeMnemonicError sz -> MkSomeMnemonicError sz -> Bool
Eq, Int -> MkSomeMnemonicError sz -> ShowS
[MkSomeMnemonicError sz] -> ShowS
MkSomeMnemonicError sz -> String
(Int -> MkSomeMnemonicError sz -> ShowS)
-> (MkSomeMnemonicError sz -> String)
-> ([MkSomeMnemonicError sz] -> ShowS)
-> Show (MkSomeMnemonicError sz)
forall (sz :: [Nat]). Int -> MkSomeMnemonicError sz -> ShowS
forall (sz :: [Nat]). [MkSomeMnemonicError sz] -> ShowS
forall (sz :: [Nat]). MkSomeMnemonicError sz -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MkSomeMnemonicError sz] -> ShowS
$cshowList :: forall (sz :: [Nat]). [MkSomeMnemonicError sz] -> ShowS
show :: MkSomeMnemonicError sz -> String
$cshow :: forall (sz :: [Nat]). MkSomeMnemonicError sz -> String
showsPrec :: Int -> MkSomeMnemonicError sz -> ShowS
$cshowsPrec :: forall (sz :: [Nat]). Int -> MkSomeMnemonicError sz -> ShowS
Show)
instance {-# OVERLAPS #-}
( n ~ EntropySize mw
, csz ~ CheckSumBits n
, ConsistentEntropy n mw csz
, MkSomeMnemonic rest
, NatVals rest
) =>
MkSomeMnemonic (mw ': rest)
where
mkSomeMnemonic :: [Text] -> Either (MkSomeMnemonicError (mw : rest)) SomeMnemonic
mkSomeMnemonic [Text]
parts = case Either (MkSomeMnemonicError (mw : rest)) SomeMnemonic
parseMW of
Left MkSomeMnemonicError (mw : rest)
err -> (MkSomeMnemonicError (mw : rest)
-> MkSomeMnemonicError (mw : rest))
-> Either (MkSomeMnemonicError (mw : rest)) SomeMnemonic
-> Either (MkSomeMnemonicError (mw : rest)) SomeMnemonic
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left (MkSomeMnemonicError (mw : rest)
-> MkSomeMnemonicError (mw : rest)
-> MkSomeMnemonicError (mw : rest)
promote MkSomeMnemonicError (mw : rest)
err) Either (MkSomeMnemonicError (mw : rest)) SomeMnemonic
parseRest
Right SomeMnemonic
mw -> SomeMnemonic
-> Either (MkSomeMnemonicError (mw : rest)) SomeMnemonic
forall a b. b -> Either a b
Right SomeMnemonic
mw
where
parseMW :: Either (MkSomeMnemonicError (mw : rest)) SomeMnemonic
parseMW = (MkSomeMnemonicError '[mw] -> MkSomeMnemonicError (mw : rest))
-> Either (MkSomeMnemonicError '[mw]) SomeMnemonic
-> Either (MkSomeMnemonicError (mw : rest)) SomeMnemonic
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left (String -> MkSomeMnemonicError (mw : rest)
forall (sz :: [Nat]). String -> MkSomeMnemonicError sz
MkSomeMnemonicError (String -> MkSomeMnemonicError (mw : rest))
-> (MkSomeMnemonicError '[mw] -> String)
-> MkSomeMnemonicError '[mw]
-> MkSomeMnemonicError (mw : rest)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MkSomeMnemonicError '[mw] -> String
forall (sz :: [Nat]). MkSomeMnemonicError sz -> String
getMkSomeMnemonicError) (Either (MkSomeMnemonicError '[mw]) SomeMnemonic
-> Either (MkSomeMnemonicError (mw : rest)) SomeMnemonic)
-> Either (MkSomeMnemonicError '[mw]) SomeMnemonic
-> Either (MkSomeMnemonicError (mw : rest)) SomeMnemonic
forall a b. (a -> b) -> a -> b
$
[Text] -> Either (MkSomeMnemonicError '[mw]) SomeMnemonic
forall (sz :: [Nat]).
MkSomeMnemonic sz =>
[Text] -> Either (MkSomeMnemonicError sz) SomeMnemonic
mkSomeMnemonic @'[mw] [Text]
parts
parseRest :: Either (MkSomeMnemonicError (mw : rest)) SomeMnemonic
parseRest = (MkSomeMnemonicError rest -> MkSomeMnemonicError (mw : rest))
-> Either (MkSomeMnemonicError rest) SomeMnemonic
-> Either (MkSomeMnemonicError (mw : rest)) SomeMnemonic
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left (String -> MkSomeMnemonicError (mw : rest)
forall (sz :: [Nat]). String -> MkSomeMnemonicError sz
MkSomeMnemonicError (String -> MkSomeMnemonicError (mw : rest))
-> (MkSomeMnemonicError rest -> String)
-> MkSomeMnemonicError rest
-> MkSomeMnemonicError (mw : rest)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MkSomeMnemonicError rest -> String
forall (sz :: [Nat]). MkSomeMnemonicError sz -> String
getMkSomeMnemonicError) (Either (MkSomeMnemonicError rest) SomeMnemonic
-> Either (MkSomeMnemonicError (mw : rest)) SomeMnemonic)
-> Either (MkSomeMnemonicError rest) SomeMnemonic
-> Either (MkSomeMnemonicError (mw : rest)) SomeMnemonic
forall a b. (a -> b) -> a -> b
$
[Text] -> Either (MkSomeMnemonicError rest) SomeMnemonic
forall (sz :: [Nat]).
MkSomeMnemonic sz =>
[Text] -> Either (MkSomeMnemonicError sz) SomeMnemonic
mkSomeMnemonic @rest [Text]
parts
promote :: MkSomeMnemonicError (mw : rest)
-> MkSomeMnemonicError (mw : rest)
-> MkSomeMnemonicError (mw : rest)
promote MkSomeMnemonicError (mw : rest)
e MkSomeMnemonicError (mw : rest)
e' =
let
sz :: [Int]
sz = Integer -> Int
forall a. Enum a => a -> Int
fromEnum (Integer -> Int) -> [Integer] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy (mw : rest) -> [Integer]
forall (ns :: [Nat]). NatVals ns => Proxy ns -> [Integer]
natVals (Proxy (mw : rest)
forall k (t :: k). Proxy t
Proxy :: Proxy (mw ': rest))
mw :: Int
mw = Integer -> Int
forall a. Enum a => a -> Int
fromEnum (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Proxy mw -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy mw
forall k (t :: k). Proxy t
Proxy :: Proxy mw)
in if [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
parts Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Int]
sz
then String -> MkSomeMnemonicError (mw : rest)
forall (sz :: [Nat]). String -> MkSomeMnemonicError sz
MkSomeMnemonicError
(String -> MkSomeMnemonicError (mw : rest))
-> String -> MkSomeMnemonicError (mw : rest)
forall a b. (a -> b) -> a -> b
$ String
"Invalid number of words: "
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> [Int] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int] -> [Int]
forall a. [a] -> [a]
init [Int]
sz)
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (if [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
sz Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 then String
" or " else String
"") String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([Int] -> Int
forall a. [a] -> a
last [Int]
sz)
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" words are expected."
else if [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
parts Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
mw then MkSomeMnemonicError (mw : rest)
e else MkSomeMnemonicError (mw : rest)
e'
class NatVals (ns :: [Nat]) where
natVals :: Proxy ns -> [Integer]
instance NatVals '[] where
natVals :: Proxy '[] -> [Integer]
natVals Proxy '[]
_ = []
instance (KnownNat n, NatVals rest) => NatVals (n ': rest) where
natVals :: Proxy (n : rest) -> [Integer]
natVals Proxy (n : rest)
_ = Proxy n -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy n
forall k (t :: k). Proxy t
Proxy :: Proxy n) Integer -> [Integer] -> [Integer]
forall a. a -> [a] -> [a]
: Proxy rest -> [Integer]
forall (ns :: [Nat]). NatVals ns => Proxy ns -> [Integer]
natVals (Proxy rest
forall k (t :: k). Proxy t
Proxy :: Proxy rest)
instance
( n ~ EntropySize mw
, csz ~ CheckSumBits n
, ConsistentEntropy n mw csz
) =>
MkSomeMnemonic (mw ': '[])
where
mkSomeMnemonic :: [Text] -> Either (MkSomeMnemonicError '[mw]) SomeMnemonic
mkSomeMnemonic [Text]
parts = do
(MkMnemonicError csz -> MkSomeMnemonicError '[mw])
-> (Mnemonic mw -> SomeMnemonic)
-> Either (MkMnemonicError csz) (Mnemonic mw)
-> Either (MkSomeMnemonicError '[mw]) SomeMnemonic
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (String -> MkSomeMnemonicError '[mw]
forall (sz :: [Nat]). String -> MkSomeMnemonicError sz
MkSomeMnemonicError (String -> MkSomeMnemonicError '[mw])
-> (MkMnemonicError csz -> String)
-> MkMnemonicError csz
-> MkSomeMnemonicError '[mw]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MkMnemonicError csz -> String
pretty) Mnemonic mw -> SomeMnemonic
forall (mw :: Nat). KnownNat mw => Mnemonic mw -> SomeMnemonic
SomeMnemonic ([Text] -> Either (MkMnemonicError csz) (Mnemonic mw)
forall (mw :: Nat) (ent :: Nat) (csz :: Nat).
(ConsistentEntropy ent mw csz, EntropySize mw ~ ent) =>
[Text] -> Either (MkMnemonicError csz) (Mnemonic mw)
mkMnemonic @mw [Text]
parts)
where
pretty :: MkMnemonicError csz -> String
pretty = \case
ErrMnemonicWords ErrWrongNumberOfWords{} ->
String
"Invalid number of words: "
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show (Proxy mw -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy mw
forall k (t :: k). Proxy t
Proxy :: Proxy mw))
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" words are expected."
ErrDictionary (ErrInvalidDictionaryWord String
_) ->
String
"Found an unknown word not present in the pre-defined dictionary. \
\The full dictionary is available here: \
\https://github.com/input-output-hk/cardano-wallet/tree/master/specifications/mnemonic/english.txt"
ErrEntropy ErrInvalidEntropyChecksum{} ->
String
"Invalid entropy checksum: please double-check the last word of \
\your mnemonic sentence."
ErrEntropy ErrInvalidEntropyLength{} ->
String
"Something went wrong when trying to generate the entropy from \
\the given mnemonic. As a user, there's nothing you can do."