Merge #1343

1343: Introduce SomeMnemonic as source of root keys (instead of entropy) r=Anviking a=Anviking

# Issue Number

#1316, preliminary work to unblock #1321 
<!-- Put here a reference to the issue this PR relates to and which requirements it tackles -->


# Overview

- Add SomeMnemonic as return type of fromMnemonic
- Make e.g. unsafeGenerateKeyFromSeed take a SomeMnemonic instead
entropy. This is more similar to `Icarus.generateKeyFromHardwareLedger`
- Add genMnemonic helper in a shared location

# Comments

<!-- Additional comments or screenshots to attach if any -->

<!-- 
Don't forget to:

 ✓ Self-review your changes to make sure nothing unexpected slipped through
 ✓ Assign yourself to the PR
 ✓ Assign one or several reviewer(s)
 ✓ Once created, link this PR to its corresponding ticket
 ✓ Assign the PR to a corresponding milestone
 ✓ Acknowledge any changes required to the Wiki
-->


Co-authored-by: Johannes Lund <johannes.lund@iohk.io>

lib/cli/src/Cardano/CLI.hs

@@ -138,7 +138,7 @@ import Cardano.Wallet.Version
 import Control.Applicative
     ( optional, some, (<|>) )
 import Control.Arrow
-    ( first, left, second )
+    ( first, left )
 import Control.Exception
     ( bracket, catch )
 import Control.Monad
@@ -151,8 +151,6 @@ import Data.Bifunctor
     ( bimap )
 import Data.Char
     ( toLower )
-import Data.Functor
-    ( (<$), (<&>) )
 import Data.List.Extra
     ( enumerate )
 import Data.List.NonEmpty
@@ -338,19 +336,16 @@ cmdMnemonicRewardCredentials =
   where
     cmd = pure exec
     exec = do
-        wSeed <- fst <$> do
+        wSeed <- do
             let prompt = "Please enter your 15–24 word mnemonic sentence: "
-            let parser = fromMnemonic @'[15,18,21,24] @"seed" . T.words
-            getLine prompt parser
-        wSndFactor <- maybe mempty fst <$> do
+            let parser = fromMnemonic @'[15,18,21,24] . T.words
+            fst <$> getLine prompt parser
+        wSndFactor <- do
             let prompt =
                     "(Enter a blank line if you didn't use a second factor.)\n"
                     <> "Please enter your 9–12 word mnemonic second factor: "
-            let parser =
-                    optionalE (fromMnemonic @'[9,12] @"generation") . T.words
-            getLine prompt parser <&> \case
-                (Nothing, _) -> Nothing
-                (Just a, t) -> Just (a, t)
+            let parser = optionalE $ fromMnemonic @'[9,12] . T.words
+            fst <$> getLine prompt parser
 
         let rootXPrv = Shelley.generateKeyFromSeed (wSeed, wSndFactor) mempty
         let rewardAccountXPrv = deriveRewardAccount mempty rootXPrv
@@ -420,24 +415,22 @@ cmdWalletCreate = command "create" $ info (helper <*> cmd) $ mempty
     exec (WalletCreateArgs wPort wName wGap) = do
         wSeed <- do
             let prompt = "Please enter a 15–24 word mnemonic sentence: "
-            let parser = fromMnemonic @'[15,18,21,24] @"seed" . T.words
-            getLine prompt parser
+            let parser = fromMnemonic @'[15,18,21,24] . T.words
+            fst <$> getLine prompt parser
         wSndFactor <- do
             let prompt =
                     "(Enter a blank line if you do not wish to use a second " <>
                     "factor.)\n" <>
                     "Please enter a 9–12 word mnemonic second factor: "
             let parser =
-                    optionalE (fromMnemonic @'[9,12] @"generation") . T.words
-            getLine prompt parser <&> \case
-                (Nothing, _) -> Nothing
-                (Just a, t) -> Just (a, t)
+                    optionalE (fromMnemonic @'[9,12]) . T.words
+            fst <$> getLine prompt parser
         wPwd <- getPassphraseWithConfirm "Please enter a passphrase: "
         runClient wPort Aeson.encodePretty $ postWallet (walletClient @t) $
             WalletPostData
                 (Just $ ApiT wGap)
-                (ApiMnemonicT . second T.words $ wSeed)
-                (ApiMnemonicT . second T.words <$> wSndFactor)
+                (ApiMnemonicT wSeed)
+                (ApiMnemonicT <$> wSndFactor)
                 (ApiT wName)
                 (ApiT wPwd)
 

lib/core/cardano-wallet-core.cabal

@@ -236,6 +236,7 @@ test-suite unit
       Cardano.Pool.DB.SqliteSpec
       Cardano.Pool.MetadataSpec
       Cardano.Pool.MetricsSpec
+      Cardano.Wallet.Gen
       Cardano.Pool.PerformanceSpec
       Cardano.Pool.RankingSpec
       Cardano.Wallet.Api.ServerSpec

lib/core/src/Cardano/Wallet/Api/Server.hs

@@ -165,8 +165,6 @@ import Cardano.Wallet.Primitive.AddressDiscovery.Sequential
     ( SeqState (..), defaultAddressPoolGap, mkSeqState )
 import Cardano.Wallet.Primitive.CoinSelection
     ( CoinSelection (..), changeBalance, feeBalance, inputBalance )
-import Cardano.Wallet.Primitive.Mnemonic
-    ( mkMnemonic )
 import Cardano.Wallet.Primitive.Model
     ( Wallet, availableBalance, currentTip, getState, totalBalance )
 import Cardano.Wallet.Primitive.Types
@@ -669,7 +667,7 @@ postShelleyWallet ctx body = do
     fst <$> getWallet ctx (mkShelleyWallet @_ @s @t @k) (ApiT wid)
   where
     seed = getApiMnemonicT (body ^. #mnemonicSentence)
-    secondFactor = maybe mempty getApiMnemonicT (body ^. #mnemonicSecondFactor)
+    secondFactor = getApiMnemonicT <$> (body ^. #mnemonicSecondFactor)
     pwd = getApiT (body ^. #passphrase)
     rootXPrv = Seq.generateKeyFromSeed (seed, secondFactor) pwd
     g = maybe defaultAddressPoolGap getApiT (body ^. #addressPoolGap)
@@ -844,25 +842,8 @@ postLedgerWallet ctx body = do
   where
     wName = getApiT (body ^. #name)
     pwd   = getApiT (body ^. #passphrase)
-    ApiMnemonicT (_, mw) = body ^. #mnemonicSentence
-
-    -- NOTE Safe because #mnemonicSentence has been parsed successfully
-    rootXPrv = case length mw of
-        n | n == 12 ->
-            let Right mnemonic = mkMnemonic @12 mw
-            in  Ica.generateKeyFromHardwareLedger mnemonic pwd
-        n | n == 15 ->
-            let Right mnemonic = mkMnemonic @15 mw
-            in  Ica.generateKeyFromHardwareLedger mnemonic pwd
-        n | n == 18 ->
-            let Right mnemonic = mkMnemonic @18 mw
-            in  Ica.generateKeyFromHardwareLedger mnemonic pwd
-        n | n == 21 ->
-            let Right mnemonic = mkMnemonic @21 mw
-            in  Ica.generateKeyFromHardwareLedger mnemonic pwd
-        _  {- 24 -} ->
-            let Right mnemonic = mkMnemonic @24 mw
-            in  Ica.generateKeyFromHardwareLedger mnemonic pwd
+    rootXPrv = Ica.generateKeyFromHardwareLedger mw pwd
+      where mw = getApiMnemonicT (body ^. #mnemonicSentence)
 
 {-------------------------------------------------------------------------------
                              ApiLayer Discrimination

lib/core/src/Cardano/Wallet/Api/Types.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingStrategies #-}
@@ -9,6 +8,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
@@ -85,7 +85,6 @@ module Cardano.Wallet.Api.Types
     -- * Polymorphic Types
     , ApiT (..)
     , ApiMnemonicT (..)
-    , getApiMnemonicT
     ) where
 
 import Prelude
@@ -98,13 +97,16 @@ import Cardano.Wallet.Primitive.AddressDerivation
     , Passphrase (..)
     , PassphraseMaxLength (..)
     , PassphraseMinLength (..)
+    , SomeMnemonic (..)
     )
 import Cardano.Wallet.Primitive.AddressDerivation.Byron
     ( decodeLegacyAddress )
 import Cardano.Wallet.Primitive.AddressDerivation.Shelley
     ( decodeShelleyAddress )
 import Cardano.Wallet.Primitive.AddressDiscovery.Sequential
     ( AddressPoolGap, getAddressPoolGap )
+import Cardano.Wallet.Primitive.Mnemonic
+    ( mnemonicToText )
 import Cardano.Wallet.Primitive.Types
     ( ActiveSlotCoefficient (..)
     , Address (..)
@@ -226,17 +228,23 @@ data ByronWalletStyle
     | Trezor
     | Ledger
 
+data SndFactor
+    = SndFactor
+
 type family StyleSymbol (style :: ByronWalletStyle) :: Symbol where
     StyleSymbol 'Random  = "random"
     StyleSymbol 'Icarus  = "icarus"
     StyleSymbol 'Trezor  = "trezor"
     StyleSymbol 'Ledger  = "ledger"
 
-type family AllowedMnemonics (style :: ByronWalletStyle) :: [Nat] where
-    AllowedMnemonics 'Random  = '[12]
-    AllowedMnemonics 'Icarus  = '[15]
-    AllowedMnemonics 'Trezor  = '[12,15,18,21,24]
-    AllowedMnemonics 'Ledger  = '[12,15,18,21,24]
+type family AllowedMnemonics (style :: k) :: [Nat]
+
+type instance AllowedMnemonics 'Random    = '[12]
+type instance AllowedMnemonics 'Icarus    = '[15]
+type instance AllowedMnemonics 'Trezor    = '[12,15,18,21,24]
+type instance AllowedMnemonics 'Ledger    = '[12,15,18,21,24]
+type instance AllowedMnemonics 'Shelley   = '[15,18,21,24]
+type instance AllowedMnemonics 'SndFactor = '[9,12]
 
 {-------------------------------------------------------------------------------
                                   API Types
@@ -323,14 +331,14 @@ data ApiUtxoStatistics = ApiUtxoStatistics
 
 data WalletPostData = WalletPostData
     { addressPoolGap :: !(Maybe (ApiT AddressPoolGap))
-    , mnemonicSentence :: !(ApiMnemonicT '[15,18,21,24] "seed")
-    , mnemonicSecondFactor :: !(Maybe (ApiMnemonicT '[9,12] "generation"))
+    , mnemonicSentence :: !(ApiMnemonicT (AllowedMnemonics 'Shelley))
+    , mnemonicSecondFactor :: !(Maybe (ApiMnemonicT (AllowedMnemonics 'SndFactor)))
     , name :: !(ApiT WalletName)
     , passphrase :: !(ApiT (Passphrase "encryption"))
     } deriving (Eq, Generic, Show)
 
 data ByronWalletPostData mw = ByronWalletPostData
-    { mnemonicSentence :: !(ApiMnemonicT mw "seed")
+    { mnemonicSentence :: !(ApiMnemonicT mw)
     , name :: !(ApiT WalletName)
     , passphrase :: !(ApiT (Passphrase "encryption"))
     } deriving (Eq, Generic, Show)
@@ -552,7 +560,7 @@ newtype ApiT a =
 --
 -- @
 -- data MyWallet
---     { mnemonic :: ApiMnemonicT '[15,18,21,24] "root-seed"
+--     { mnemonic :: ApiMnemonicT '[15,18,21,24]
 --     }
 -- @
 --
@@ -563,13 +571,10 @@ newtype ApiT a =
 -- mnemonic words that was parsed. This is only to be able to implement the
 -- 'ToJSON' instances and roundtrip, which is a very dubious argument. In
 -- practice, we'll NEVER peek at the mnemonic, output them and whatnot.
-newtype ApiMnemonicT (sizes :: [Nat]) (purpose :: Symbol) =
-    ApiMnemonicT (Passphrase purpose, [Text])
+newtype ApiMnemonicT (sizes :: [Nat]) =
+    ApiMnemonicT { getApiMnemonicT :: SomeMnemonic }
     deriving (Generic, Show, Eq)
 
-getApiMnemonicT :: ApiMnemonicT sizes purpose -> Passphrase purpose
-getApiMnemonicT (ApiMnemonicT (pw, _)) = pw
-
 {-------------------------------------------------------------------------------
                                JSON Instances
 -------------------------------------------------------------------------------}
@@ -631,7 +636,7 @@ instance FromJSON WalletPostData where
 instance ToJSON  WalletPostData where
     toJSON = genericToJSON defaultRecordTypeOptions
 
-instance FromMnemonic mw "seed" => FromJSON (ByronWalletPostData mw) where
+instance FromMnemonic mw => FromJSON (ByronWalletPostData mw) where
     parseJSON = genericParseJSON defaultRecordTypeOptions
 instance ToJSON (ByronWalletPostData mw) where
     toJSON = genericToJSON defaultRecordTypeOptions
@@ -662,15 +667,15 @@ instance (PassphraseMaxLength purpose, PassphraseMinLength purpose)
 instance ToJSON (ApiT (Passphrase purpose)) where
     toJSON = toJSON . toText . getApiT
 
-instance FromMnemonic sizes purpose => FromJSON (ApiMnemonicT sizes purpose)
+instance FromMnemonic sizes => FromJSON (ApiMnemonicT sizes)
   where
     parseJSON bytes = do
         xs <- parseJSON bytes
-        m <- eitherToParser $ left ShowFmt $ fromMnemonic @sizes @purpose xs
-        return $ ApiMnemonicT (m, xs)
+        m <- eitherToParser $ left ShowFmt $ fromMnemonic @sizes xs
+        return $ ApiMnemonicT m
 
-instance ToJSON (ApiMnemonicT sizes purpose) where
-    toJSON (ApiMnemonicT (!_, xs)) = toJSON xs
+instance ToJSON (ApiMnemonicT sizes) where
+    toJSON (ApiMnemonicT (SomeMnemonic mw)) = toJSON (mnemonicToText mw)
 
 instance FromJSON (ApiT WalletId) where
     parseJSON = parseJSON >=> eitherToParser . bimap ShowFmt ApiT . fromText

lib/core/src/Cardano/Wallet/Primitive/AddressDerivation.hs

@@ -4,13 +4,15 @@
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE RoleAnnotations #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
@@ -75,6 +77,7 @@ module Cardano.Wallet.Primitive.AddressDerivation
     , Passphrase(..)
     , PassphraseMinLength(..)
     , PassphraseMaxLength(..)
+    , SomeMnemonic(..)
     , FromMnemonic(..)
     , FromMnemonicError(..)
     , ErrWrongPassphrase(..)
@@ -92,11 +95,10 @@ import Cardano.Wallet.Primitive.Mnemonic
     , DictionaryError (..)
     , EntropyError (..)
     , EntropySize
+    , Mnemonic
     , MnemonicError (..)
     , MnemonicWordsError (..)
-    , entropyToBytes
     , mkMnemonic
-    , mnemonicToEntropy
     )
 import Cardano.Wallet.Primitive.Types
     ( Address (..), ChimericAccount (..), Hash (..) )
@@ -113,7 +115,7 @@ import Crypto.KDF.PBKDF2
 import Crypto.Random.Types
     ( MonadRandom (..) )
 import Data.Bifunctor
-    ( first )
+    ( bimap )
 import Data.ByteArray
     ( ByteArray, ByteArrayAccess, ScrubbedBytes )
 import Data.ByteArray.Encoding
@@ -136,6 +138,8 @@ import Data.Text.Class
     , fromTextToBoundedEnum
     , toTextFromBoundedEnum
     )
+import Data.Type.Equality
+    ( (:~:) (..), testEquality )
 import Data.Typeable
     ( Typeable )
 import Data.Word
@@ -146,6 +150,8 @@ import GHC.Generics
     ( Generic )
 import GHC.TypeLits
     ( KnownNat, Nat, Symbol, natVal )
+import Type.Reflection
+    ( typeOf )
 
 import qualified Basement.Compat.Base as B
 import qualified Data.ByteArray as BA
@@ -386,6 +392,16 @@ instance
 instance ToText (Passphrase purpose) where
     toText (Passphrase bytes) = T.decodeUtf8 $ BA.convert bytes
 
+data SomeMnemonic where
+    SomeMnemonic :: forall mw. KnownNat mw => Mnemonic mw -> SomeMnemonic
+
+deriving instance Show SomeMnemonic
+instance Eq SomeMnemonic where
+    (SomeMnemonic mwa) == (SomeMnemonic mwb) =
+        case typeOf mwa `testEquality` typeOf mwb of
+            Nothing -> False
+            Just Refl -> mwa == mwb
+
 -- | Create a passphrase from a mnemonic sentence. This class enables caller to
 -- parse text list of variable length into mnemonic sentences.
 --
@@ -394,8 +410,8 @@ instance ToText (Passphrase purpose) where
 --
 -- Note that the given 'Nat's **have** to be valid mnemonic sizes, otherwise the
 -- underlying code won't even compile, with not-so-friendly error messages.
-class FromMnemonic (sz :: [Nat]) (purpose :: Symbol) where
-    fromMnemonic :: [Text] -> Either (FromMnemonicError sz) (Passphrase purpose)
+class FromMnemonic (sz :: [Nat]) where
+    fromMnemonic :: [Text] -> Either (FromMnemonicError sz) SomeMnemonic
 
 -- | Error reported from trying to create a passphrase from a given mnemonic
 newtype FromMnemonicError (sz :: [Nat]) =
@@ -407,19 +423,19 @@ instance {-# OVERLAPS #-}
     ( n ~ EntropySize mw
     , csz ~ CheckSumBits n
     , ConsistentEntropy n mw csz
-    , FromMnemonic rest purpose
+    , FromMnemonic rest
     , NatVals rest
     ) =>
-    FromMnemonic (mw ': rest) purpose
+    FromMnemonic (mw ': rest)
   where
     fromMnemonic parts = case parseMW of
         Left err -> left (promote err) parseRest
         Right mw -> Right mw
       where
         parseMW = left (FromMnemonicError . getFromMnemonicError) $ -- coerce
-            fromMnemonic @'[mw] @purpose parts
+            fromMnemonic @'[mw] parts
         parseRest = left (FromMnemonicError . getFromMnemonicError) $ -- coerce
-            fromMnemonic @rest @purpose parts
+            fromMnemonic @rest parts
         promote e e' =
             let
                 sz = fromEnum <$> natVals (Proxy :: Proxy (mw ': rest))
@@ -447,11 +463,10 @@ instance
     , csz ~ CheckSumBits n
     , ConsistentEntropy n mw csz
     ) =>
-    FromMnemonic (mw ': '[]) purpose
+    FromMnemonic (mw ': '[])
   where
     fromMnemonic parts = do
-        m <- first (FromMnemonicError . pretty) (mkMnemonic @mw parts)
-        return $ Passphrase $ entropyToBytes $ mnemonicToEntropy m
+        bimap (FromMnemonicError . pretty) SomeMnemonic (mkMnemonic @mw parts)
       where
         pretty = \case
             ErrMnemonicWords ErrWrongNumberOfWords{} ->