diff --git a/lib/cli/cardano-wallet-cli.cabal b/lib/cli/cardano-wallet-cli.cabal index a289449afcc..07a170ecc0b 100644 --- a/lib/cli/cardano-wallet-cli.cabal +++ b/lib/cli/cardano-wallet-cli.cabal @@ -44,6 +44,7 @@ library , fmt , http-client , iohk-monitoring + , memory , servant-client , servant-client-core , text @@ -69,12 +70,14 @@ test-suite unit -Werror build-depends: base + , bytestring , cardano-wallet-cli , cardano-wallet-core , filepath , hspec , optparse-applicative , QuickCheck + , silently , temporary , text , text-class diff --git a/lib/cli/src/Cardano/CLI.hs b/lib/cli/src/Cardano/CLI.hs index 86336756c5f..d186239ea7e 100644 --- a/lib/cli/src/Cardano/CLI.hs +++ b/lib/cli/src/Cardano/CLI.hs @@ -1,18 +1,22 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} -- | -- Copyright: © 2018-2020 IOHK @@ -34,6 +38,7 @@ module Cardano.CLI , cmdStakePool , cmdNetwork , cmdVersion + , cmdKey -- * Option & Argument Parsers , optionT @@ -57,6 +62,15 @@ module Cardano.CLI , TxId , MnemonicSize (..) , Port (..) + , CliKeyScheme (..) + , CliWalletStyle (..) + + , newCliKeyScheme + , hexTextToXPrv + , xPrvToHexText + , hoistKeyScheme + , mapKey + -- * Logging , withLogging @@ -102,6 +116,7 @@ import Cardano.Wallet.Api.Server ( HostPreference, Listen (..) ) import Cardano.Wallet.Api.Types ( AddressAmount + , AllowedMnemonics , ApiEpochNumber , ApiMnemonicT (..) , ApiT (..) @@ -120,13 +135,22 @@ import Cardano.Wallet.Api.Types import Cardano.Wallet.Network ( ErrNetworkUnavailable (..) ) import Cardano.Wallet.Primitive.AddressDerivation - ( FromMnemonic (..) + ( ErrUnXPrvStripPub (..) + , ErrXPrvFromStrippedPubXPrv (..) + , FromMnemonic (..) + , FromMnemonicError (..) + , NatVals (..) , Passphrase (..) , PassphraseMaxLength , PassphraseMinLength + , SomeMnemonic (..) , WalletKey (..) + , XPrv , deriveRewardAccount + , hex , unXPrv + , unXPrvStripPub + , xPrvFromStrippedPubXPrv ) import Cardano.Wallet.Primitive.AddressDiscovery.Sequential ( AddressPoolGap, defaultAddressPoolGap ) @@ -143,27 +167,40 @@ import Control.Arrow import Control.Exception ( bracket, catch ) import Control.Monad - ( join, unless, void, when ) + ( join, unless, void, when, (>=>) ) import Control.Tracer ( Tracer, traceWith ) import Data.Aeson ( (.:) ) import Data.Bifunctor ( bimap ) +import Data.ByteArray.Encoding + ( Base (Base16), convertFromBase ) import Data.Char ( toLower ) +import Data.List + ( intercalate ) import Data.List.Extra ( enumerate ) import Data.List.NonEmpty ( NonEmpty (..) ) import Data.Maybe ( fromMaybe ) +import Data.Proxy + ( Proxy (..) ) import Data.String ( IsString ) import Data.Text ( Text ) import Data.Text.Class - ( FromText (..), TextDecodingError (..), ToText (..), showT ) + ( CaseStyle (..) + , FromText (..) + , TextDecodingError (..) + , ToText (..) + , fromTextToBoundedEnum + , showT + , toTextFromBoundedEnum + ) import Data.Text.Read ( decimal ) import Data.Void @@ -198,6 +235,7 @@ import Options.Applicative , footer , header , help + , helpDoc , helper , hidden , info @@ -213,6 +251,8 @@ import Options.Applicative , subparser , value ) +import Options.Applicative.Help.Pretty + ( string, vsep ) import Options.Applicative.Types ( ReadM (..), readerAsk ) import Servant.Client @@ -249,6 +289,7 @@ import System.IO , hGetEcho , hIsTerminalDevice , hPutChar + , hPutStrLn , hSetBuffering , hSetEcho , stderr @@ -258,6 +299,8 @@ import System.IO import qualified Cardano.BM.Configuration.Model as CM import qualified Cardano.BM.Data.BackendKind as CM +import qualified Cardano.Wallet.Api.Types as API +import qualified Cardano.Wallet.Primitive.AddressDerivation.Icarus as Icarus import qualified Cardano.Wallet.Primitive.AddressDerivation.Shelley as Shelley import qualified Codec.Binary.Bech32 as Bech32 import qualified Codec.Binary.Bech32.TH as Bech32 @@ -266,6 +309,7 @@ import qualified Data.Aeson.Encode.Pretty as Aeson import qualified Data.Aeson.Types as Aeson import qualified Data.Bifunctor as Bi import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Char8 as BL8 import qualified Data.List.NonEmpty as NE @@ -297,6 +341,169 @@ runCli = join . customExecParser preferences where preferences = prefs showHelpOnEmpty +{------------------------------------------------------------------------------- + Commands - 'HD Derivation' +-------------------------------------------------------------------------------} + +cmdKey :: Mod CommandFields (IO ()) +cmdKey = command "key" $ info (helper <*> cmds) $ mempty + <> progDesc "Derive keys from mnemonics." + where + cmds = subparser $ mempty + <> cmdRootKey + + +-- | Record with mnemonic and key derivation funcionality — /without/ any type +-- parameters related to scheme. +-- +-- This means that we can have a value for byron, a value for icarus, both with +-- the same type @CliKeyScheme@. +-- +-- @CliKeyScheme@ is on the other hand parameterized over @key@ and @m@. +-- @hoistKeyScheme@ is provided for mapping over @m@. @mapKey@ is provided for +-- mapping over @key@. +-- +-- This way we can test mapping @XPrv@s to @Text@ as pure code in +-- @Either String@, rather than @IO@. +data CliKeyScheme key m = CliKeyScheme + { allowedWordLengths :: [Int] + , mnemonicToRootKey :: [Text] -> m key + } + +-- | Change the underlying monad of a @CliKeyScheme@. +hoistKeyScheme + :: (forall a. m1 a -> m2 a) + -> CliKeyScheme key m1 + -> CliKeyScheme key m2 +hoistKeyScheme eta s = CliKeyScheme + { allowedWordLengths = allowedWordLengths s + , mnemonicToRootKey = eta . mnemonicToRootKey s + } + +xPrvToHexText :: XPrv -> Either String Text +xPrvToHexText = left showErr . fmap (T.pack . B8.unpack . hex) . unXPrvStripPub + where + showErr ErrCannotRoundtrip = + "That private key looks weird. Is it encrypted? Or an old Byron key?" + +hexTextToXPrv :: Text -> Either String XPrv +hexTextToXPrv txt = do + bytes <- fromHex $ B8.pack $ T.unpack txt + left showErr $ xPrvFromStrippedPubXPrv bytes + where + showErr (ErrInputLengthMismatch expected actual) = mconcat + [ "Expected extended private key to be " + , show expected + , " bytes but got " + , show actual + , " bytes." + ] + showErr (ErrInternalError msg) = mconcat + [ "Unexpected crypto error: " + , msg + ] + fromHex = left (const "Invalid hex.") + . convertFromBase Base16 + +-- | Map over the key type of a CliKeyScheme. +-- +-- Can be used with e.g @xPrvToHexText@. +mapKey + :: Monad m + => (key1 -> m key2) + -> CliKeyScheme key1 m + -> CliKeyScheme key2 m +mapKey f s = CliKeyScheme + { allowedWordLengths = allowedWordLengths s + , mnemonicToRootKey = (mnemonicToRootKey s) >=> f + } + +eitherToIO :: Either String a -> IO a +eitherToIO (Right a) = return a +eitherToIO (Left e) = hPutStrLn stderr e >> exitFailure + +data CliWalletStyle = Icarus | Ledger | Trezor + deriving (Show, Eq, Generic, Bounded, Enum) + +instance FromText CliWalletStyle where + fromText = fromTextToBoundedEnum SnakeLowerCase + +instance ToText CliWalletStyle where + toText = toTextFromBoundedEnum SnakeLowerCase + +newCliKeyScheme :: CliWalletStyle -> CliKeyScheme XPrv (Either String) +newCliKeyScheme = \case + Icarus -> + let + proxy = Proxy @'API.Icarus + in + CliKeyScheme + (apiAllowedLengths proxy) + (fmap icarusKeyFromSeed . seedFromMnemonic proxy) + Trezor -> + let + proxy = Proxy @'API.Trezor + in + CliKeyScheme + (apiAllowedLengths proxy) + (fmap icarusKeyFromSeed . seedFromMnemonic proxy) + Ledger -> + let + proxy = Proxy @'API.Ledger + in + CliKeyScheme + (apiAllowedLengths proxy) + (fmap ledgerKeyFromSeed . seedFromMnemonic proxy) + + where + seedFromMnemonic + :: forall (s :: API.ByronWalletStyle). + (FromMnemonic (AllowedMnemonics s)) + => Proxy s + -> [Text] + -> Either String SomeMnemonic + seedFromMnemonic _ = + left getFromMnemonicError . fromMnemonic @(AllowedMnemonics s) + + apiAllowedLengths + :: forall (s :: API.ByronWalletStyle). ( NatVals (AllowedMnemonics s)) + => Proxy s + -> [Int] + apiAllowedLengths _ = + (map fromIntegral (natVals $ Proxy @(AllowedMnemonics s))) + + icarusKeyFromSeed :: SomeMnemonic -> XPrv + icarusKeyFromSeed = Icarus.getKey . flip Icarus.generateKeyFromSeed pass + + ledgerKeyFromSeed :: SomeMnemonic -> XPrv + ledgerKeyFromSeed = Icarus.getKey + . flip Icarus.generateKeyFromHardwareLedger pass + + -- We don't use passwords to encrypt the keys here. + pass = mempty + +data KeyRootArgs = KeyRootArgs + { _walletStyle :: CliWalletStyle + , _mnemonicWords :: [Text] + } + +cmdRootKey :: Mod CommandFields (IO ()) +cmdRootKey = + command "root" $ info (helper <*> cmd) $ mempty + <> progDesc "Extract root extended private key from a mnemonic sentence." + where + cmd = fmap exec $ + KeyRootArgs <$> walletStyleOption <*> mnemonicWordsArgument + exec (KeyRootArgs keyType ws) = do + xprv <- mnemonicToRootKey scheme ws + TIO.putStrLn xprv + where + scheme :: CliKeyScheme Text IO + scheme = + hoistKeyScheme eitherToIO + . mapKey xPrvToHexText + $ newCliKeyScheme keyType + {------------------------------------------------------------------------------- Commands - 'mnemonic' -------------------------------------------------------------------------------} @@ -1013,6 +1220,49 @@ loggingSeverityOrOffReader = do "off" -> pure Nothing _ -> Just <$> loggingSeverityReader +-- | [--wallet-style=WALLET_STYLE] +-- +-- Note that we in the future might replace the type @CliWalletStyle@ with +-- another type, to include Shelley keys. +walletStyleOption :: Parser CliWalletStyle +walletStyleOption = option (eitherReader fromTextS) + ( long "wallet-style" + <> metavar "WALLET_STYLE" + <> helpDoc (Just (vsep typeOptions)) + ) + where + typeOptions = string <$> + [ "Any of the following:" + , " icarus (" ++ allowedWords Icarus ++ ")" + , " trezor (" ++ allowedWords Trezor ++ ")" + , " ledger (" ++ allowedWords Ledger ++ ")" + ] + + allowedWords = (++ " words") + . formatEnglishEnumeration + . map show + . allowedWordLengths + . newCliKeyScheme + where + -- >>> formatEnglishEnumeration ["a", "b", "c"] + -- "a, b or c" + -- + -- >>> formatEnglishEnumeration ["a", "b"] + -- "a or b" + -- + -- >>> formatEnglishEnumeration ["a"] + -- "a" + formatEnglishEnumeration = formatEnglishEnumerationRev . reverse + formatEnglishEnumerationRev [ult, penult] + = penult ++ " or " ++ ult + formatEnglishEnumerationRev (ult:penult:revBeginning) + = intercalate ", " (reverse revBeginning) + ++ ", " + ++ penult + ++ " or " + ++ ult + formatEnglishEnumerationRev xs = intercalate ", " (reverse xs) + -- | walletIdArgument :: Parser WalletId walletIdArgument = argumentT $ mempty @@ -1040,6 +1290,10 @@ transactionSubmitPayloadArgument = argumentT $ mempty <> metavar "BINARY_BLOB" <> help "hex-encoded binary blob of externally-signed transaction." +-- | +mnemonicWordsArgument :: Parser [Text] +mnemonicWordsArgument = some (argument str (metavar "MNEMONIC_WORD...")) + -- | Helper for writing an option 'Parser' using a 'FromText' instance. optionT :: FromText a => Mod OptionFields a -> Parser a optionT = option (eitherReader fromTextS) diff --git a/lib/cli/test/unit/Cardano/CLISpec.hs b/lib/cli/test/unit/Cardano/CLISpec.hs index 1c85147209d..b4cf1cd7783 100644 --- a/lib/cli/test/unit/Cardano/CLISpec.hs +++ b/lib/cli/test/unit/Cardano/CLISpec.hs @@ -2,7 +2,9 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Cardano.CLISpec @@ -12,11 +14,14 @@ module Cardano.CLISpec import Prelude import Cardano.CLI - ( MnemonicSize (..) + ( CliKeyScheme (..) + , CliWalletStyle (..) + , MnemonicSize (..) , Port (..) , TxId , cli , cmdAddress + , cmdKey , cmdMnemonic , cmdNetwork , cmdStakePool @@ -24,13 +29,28 @@ import Cardano.CLI , cmdWallet , hGetLine , hGetSensitiveLine + , hexTextToXPrv + , mapKey + , newCliKeyScheme + , xPrvToHexText ) import Cardano.Wallet.Primitive.AddressDerivation - ( NetworkDiscriminant (..) ) + ( NetworkDiscriminant (..), XPrv, unXPrv ) +import Cardano.Wallet.Primitive.Mnemonic + ( ConsistentEntropy + , EntropySize + , Mnemonic + , entropyToMnemonic + , mnemonicToText + ) +import Cardano.Wallet.Unsafe + ( unsafeMkEntropy ) import Control.Concurrent ( forkFinally ) import Control.Concurrent.MVar ( newEmptyMVar, putMVar, takeMVar ) +import Control.Exception + ( SomeException, try ) import Control.Monad ( mapM_ ) import Data.Proxy @@ -39,57 +59,93 @@ import Data.Text ( Text ) import Data.Text.Class ( FromText (..), TextDecodingError (..), toText ) +import GHC.TypeLits + ( natVal ) import Options.Applicative ( ParserResult (..), columns, execParserPure, prefs, renderFailure ) +import System.Exit + ( ExitCode (..) ) import System.FilePath ( () ) import System.IO - ( Handle, IOMode (..), hClose, openFile ) + ( Handle, IOMode (..), hClose, openFile, stderr ) +import System.IO.Silently + ( capture_, hCapture_ ) import System.IO.Temp ( withSystemTempDirectory ) import Test.Hspec - ( Spec, describe, it, shouldBe ) + ( Spec, describe, expectationFailure, it, shouldBe, shouldStartWith ) import Test.QuickCheck ( Arbitrary (..) + , Gen , Large (..) + , Property , arbitraryBoundedEnum , checkCoverage , counterexample , cover + , expectFailure + , forAll , genericShrink + , oneof , property + , vectorOf + , (.&&.) , (===) ) import Test.Text.Roundtrip ( textRoundtrip ) +import qualified Data.ByteString as BS import qualified Data.Text as T import qualified Data.Text.IO as TIO spec :: Spec spec = do - describe "Specification / Usage Overview" $ do - let parser = cli $ mempty - <> cmdMnemonic - <> cmdWallet @'Testnet - <> cmdTransaction @'Testnet - <> cmdAddress @'Testnet - <> cmdStakePool @'Testnet - <> cmdNetwork @'Testnet - let defaultPrefs = prefs (mempty <> columns 65) - - let expectationFailure = flip counterexample False + let defaultPrefs = prefs (mempty <> columns 65) + + let parser = cli $ mempty + <> cmdMnemonic + <> cmdWallet @'Testnet + <> cmdTransaction @'Testnet + <> cmdAddress @'Testnet + <> cmdStakePool @'Testnet + <> cmdNetwork @'Testnet + <> cmdKey + + + let shouldStdOut args expected = it (unwords args) $ + case execParserPure defaultPrefs parser args of + Success x -> capture_ x >>= (`shouldBe` expected) + CompletionInvoked _ -> expectationFailure + "expected parser to show usage but it offered completion" + Failure failure -> + expectationFailure $ "parser failed with: " ++ show failure + let expectStdErr args expectation = it (unwords args) $ + case execParserPure defaultPrefs parser args of + Success x -> + hCapture_ [stderr] (try @SomeException x) >>= (expectation) + CompletionInvoked _ -> expectationFailure + "expected parser to show usage but it offered completion" + Failure failure -> do + let (str, code) = renderFailure failure "" + code `shouldBe` (ExitFailure 1) + expectation str + describe "Specification / Usage Overview" $ do + let expectationFailure' = flip counterexample False let shouldShowUsage args expected = it (unwords args) $ case execParserPure defaultPrefs parser args of - Success _ -> expectationFailure + Success _ -> expectationFailure' "expected parser to show usage but it has succeeded" - CompletionInvoked _ -> expectationFailure + CompletionInvoked _ -> expectationFailure' "expected parser to show usage but it offered completion" Failure failure -> property $ let (usage, _) = renderFailure failure mempty - in counterexample usage $ expected === lines usage + msg = "*** Expected:\n" ++ (unlines expected) + ++ "*** but actual usage is:\n" ++ usage + in counterexample msg $ expected === lines usage ["--help"] `shouldShowUsage` [ "The CLI is a proxy to the wallet server, which is required for" @@ -111,6 +167,7 @@ spec = do , " address Manage addresses." , " stake-pool Manage stake pools." , " network Manage network." + , " key Derive keys from mnemonics." ] ["mnemonic", "--help"] `shouldShowUsage` @@ -147,6 +204,19 @@ spec = do , "!!! Only for the Incentivized Testnet !!!" ] + + ["key", "--help"] `shouldShowUsage` + [ "Usage: key COMMAND" + , " Derive keys from mnemonics." + , "" + , "Available options:" + , " -h,--help Show this help text" + , "" + , "Available commands:" + , " root Extract root extended private key from" + , " a mnemonic sentence." + ] + ["wallet", "--help"] `shouldShowUsage` [ "Usage: wallet COMMAND" , " Manage wallets." @@ -384,9 +454,23 @@ spec = do , " EPOCH_NUMBER epoch number parameter or 'latest'" ] + ["key", "root", "--help"] `shouldShowUsage` + [ "Usage: key root --wallet-style WALLET_STYLE MNEMONIC_WORD..." + , " Extract root extended private key from a mnemonic sentence." + , "" + , "Available options:" + , " -h,--help Show this help text" + , " --wallet-style WALLET_STYLE" + , " Any of the following:" + , " icarus (15 words)" + , " trezor (12, 15, 18, 21 or 24 words)" + , " ledger (12, 15, 18, 21 or 24 words)" + ] + describe "Can perform roundtrip textual encoding & decoding" $ do textRoundtrip $ Proxy @(Port "test") textRoundtrip $ Proxy @MnemonicSize + textRoundtrip $ Proxy @CliWalletStyle describe "Transaction ID decoding from text" $ do @@ -473,10 +557,128 @@ spec = do , expectedStdout = "Prompt: ******\ESC[1D \ESC[1D\ESC[1D \ESC[1D**\n" , expectedResult = "pata14" :: Text } + + let mw15 = words "message mask aunt wheel ten maze between tomato slow \ + \analyst ladder such report capital produce" + let mw12 = words "broccoli side goddess shaft alarm victory sheriff \ + \combine birth deny train outdoor" + describe "key derivation from mnemonics" $ do + (["key", "root", "--wallet-style", "icarus"] ++ mw15) `shouldStdOut` + "00aa5f5f364980f4ac6295fd0fbf65643390d6bb1cf76536c2ebb02713c8ba50d8\ + \903bee774b7bf8678ea0d6fded6d876db3b42bef687640cc514eb73f767537a8c7\ + \54f89bc9cc83533eab257d7c94625c95f0d749710428f5aa2404eeb6499b\n" + (["key", "root", "--wallet-style", "trezor"] ++ mw15) `shouldStdOut` + "00aa5f5f364980f4ac6295fd0fbf65643390d6bb1cf76536c2ebb02713c8ba50d8\ + \903bee774b7bf8678ea0d6fded6d876db3b42bef687640cc514eb73f767537a8c7\ + \54f89bc9cc83533eab257d7c94625c95f0d749710428f5aa2404eeb6499b\n" + (["key", "root", "--wallet-style", "ledger"] ++ mw15) `shouldStdOut` + "003a914372e711b910a75b87e98695929b6960bd5380cfd766b572ea844ea14080\ + \9eb7ad13f798d06ce550a9f6c48dd2151db4593e67dbd2821d75378c7350f1366b\ + \85e0be9cdec2213af2084d462cc11e85c215e0f003acbeb996567e371502\n" + + describe "key derivation (negative tests)" $ do + (["key", "root", "--wallet-style", "icarus"] ++ mw12) `expectStdErr` + (`shouldBe` "Invalid number of words: 15 words are expected.\n") + + (["key", "root", "--wallet-style", "icarus"]) `expectStdErr` + (`shouldStartWith` "Missing: MNEMONIC_WORD...") + + let shrug = "¯\\_(ツ)_/¯" + (["key", "root", "--wallet-style", "icarus"] ++ (replicate 15 shrug)) + `expectStdErr` (`shouldBe` + "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/spe\ + \cifications/mnemonic/english.txt\n") + + describe "CliKeyScheme" $ do + it "all allowedWordLengths are supported" + $ property prop_allowedWordLengthsAllWork + + it "scheme == scheme (reflexivity)" $ property $ \s -> + propCliKeySchemeEquality + (newCliKeyScheme s) + (newCliKeyScheme s) + + -- This tests provides a stronger guarantee than merely knowing that + -- unsafeHexTextToXPrv and xPrvToHexText roundtrips. + it "scheme == mapKey (fromHex . toHex) scheme" + $ property prop_roundtripCliKeySchemeKeyViaHex + + it "random /= icarus" $ do + expectFailure $ propCliKeySchemeEquality + (newCliKeyScheme Ledger) + (newCliKeyScheme Icarus) + where backspace :: Text backspace = T.singleton (toEnum 127) +prop_roundtripCliKeySchemeKeyViaHex :: CliWalletStyle -> Property +prop_roundtripCliKeySchemeKeyViaHex style = + propCliKeySchemeEquality + (newCliKeyScheme style) + (mapKey hexTextToXPrv + . mapKey xPrvToHexText + $ newCliKeyScheme style) + +prop_allowedWordLengthsAllWork :: CliWalletStyle -> Property +prop_allowedWordLengthsAllWork style = do + (forAll (genAllowedMnemonic s) propCanRetrieveRootKey) + where + s :: CliKeyScheme XPrv (Either String) + s = newCliKeyScheme style + + propCanRetrieveRootKey :: [Text] -> Property + propCanRetrieveRootKey mw = case mnemonicToRootKey s mw of + Right _ -> property True + Left e -> counterexample + (show (length mw) ++ " words, failed with: " ++ e) + (property False) + +propCliKeySchemeEquality + :: CliKeyScheme XPrv (Either String) + -> CliKeyScheme XPrv (Either String) + -> Property +propCliKeySchemeEquality s1 s2 = do + (forAll (genAllowedMnemonic s1) propSameMnem) + .&&. + (allowedWordLengths s1) === (allowedWordLengths s2) + where + propSameMnem :: [Text] -> Property + propSameMnem mw = (mnemonicToRootKey s1 mw) === (mnemonicToRootKey s2 mw) + +genAllowedMnemonic :: CliKeyScheme key m -> Gen [Text] +genAllowedMnemonic s = oneof (map genMnemonicOfSize $ allowedWordLengths s) + +genMnemonicOfSize :: Int -> Gen [Text] +genMnemonicOfSize = \case + 12 -> mnemonicToText <$> genMnemonic @12 + 15 -> mnemonicToText <$> genMnemonic @15 + 18 -> mnemonicToText <$> genMnemonic @18 + 21 -> mnemonicToText <$> genMnemonic @21 + 24 -> mnemonicToText <$> genMnemonic @24 + n -> error $ "when this test was written, " ++ show n ++ + " was not a valid length of a mnemonic" + +instance Show XPrv where + show = show . unXPrv + +instance Eq XPrv where + a == b = unXPrv a == unXPrv b + +genMnemonic + :: forall mw ent csz. + ( ConsistentEntropy ent mw csz + , EntropySize mw ~ ent + ) + => Gen (Mnemonic mw) +genMnemonic = do + let n = fromIntegral (natVal $ Proxy @(EntropySize mw)) `div` 8 + bytes <- BS.pack <$> vectorOf n arbitrary + let ent = unsafeMkEntropy @(EntropySize mw) bytes + return $ entropyToMnemonic ent + {------------------------------------------------------------------------------- hGetSensitiveLine -------------------------------------------------------------------------------} @@ -532,6 +734,10 @@ instance Arbitrary MnemonicSize where arbitrary = arbitraryBoundedEnum shrink = genericShrink +instance Arbitrary CliWalletStyle where + arbitrary = arbitraryBoundedEnum + shrink = genericShrink + instance Arbitrary (Port "test") where arbitrary = arbitraryBoundedEnum shrink p diff --git a/lib/jormungandr/exe/cardano-wallet-jormungandr.hs b/lib/jormungandr/exe/cardano-wallet-jormungandr.hs index 23f4a2a0076..58dbb2faccf 100644 --- a/lib/jormungandr/exe/cardano-wallet-jormungandr.hs +++ b/lib/jormungandr/exe/cardano-wallet-jormungandr.hs @@ -33,6 +33,7 @@ import Cardano.CLI , Port (..) , cli , cmdAddress + , cmdKey , cmdMnemonic , cmdNetwork , cmdStakePool @@ -159,6 +160,7 @@ main = withUtf8Encoding $ do <> cmdStakePool @'Testnet <> cmdNetwork @'Testnet <> cmdVersion + <> cmdKey beforeMainLoop :: Trace IO MainLog diff --git a/nix/.stack.nix/cardano-wallet-cli.nix b/nix/.stack.nix/cardano-wallet-cli.nix index 688a76c21d2..f630896faf9 100644 --- a/nix/.stack.nix/cardano-wallet-cli.nix +++ b/nix/.stack.nix/cardano-wallet-cli.nix @@ -72,6 +72,7 @@ in { system, compiler, flags, pkgs, hsPkgs, pkgconfPkgs, ... }: (hsPkgs."fmt" or (buildDepError "fmt")) (hsPkgs."http-client" or (buildDepError "http-client")) (hsPkgs."iohk-monitoring" or (buildDepError "iohk-monitoring")) + (hsPkgs."memory" or (buildDepError "memory")) (hsPkgs."servant-client" or (buildDepError "servant-client")) (hsPkgs."servant-client-core" or (buildDepError "servant-client-core")) (hsPkgs."text" or (buildDepError "text")) @@ -84,12 +85,14 @@ in { system, compiler, flags, pkgs, hsPkgs, pkgconfPkgs, ... }: "unit" = { depends = [ (hsPkgs."base" or (buildDepError "base")) + (hsPkgs."bytestring" or (buildDepError "bytestring")) (hsPkgs."cardano-wallet-cli" or (buildDepError "cardano-wallet-cli")) (hsPkgs."cardano-wallet-core" or (buildDepError "cardano-wallet-core")) (hsPkgs."filepath" or (buildDepError "filepath")) (hsPkgs."hspec" or (buildDepError "hspec")) (hsPkgs."optparse-applicative" or (buildDepError "optparse-applicative")) (hsPkgs."QuickCheck" or (buildDepError "QuickCheck")) + (hsPkgs."silently" or (buildDepError "silently")) (hsPkgs."temporary" or (buildDepError "temporary")) (hsPkgs."text" or (buildDepError "text")) (hsPkgs."text-class" or (buildDepError "text-class"))