Add unXPrvStripPub (& inverse) that matches jcli

- Roundtrip properties
- Integration test verifying that it works with jcli

Why:

We need to convert between 96-byte long hex-encoded bytestrings and
XPrvs when implementing the `key root` and `key child` CLI commands.

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

@@ -55,8 +55,14 @@ module Cardano.Wallet.Primitive.AddressDerivation
     , unXPrv
     , xprv
     , xpub
+
+    -- * Helpers
     , hex
     , fromHex
+    , unXPrvStripPub
+    , xPrvFromStrippedPubXPrv
+    , ErrXPrvFromStrippedPubXPrv (..)
+    , ErrUnXPrvStripPub (..)
 
     -- * Network Discrimination
     , NetworkDiscriminant (..)
@@ -154,6 +160,7 @@ import Type.Reflection
     ( typeOf )
 
 import qualified Basement.Compat.Base as B
+import qualified Cardano.Crypto.Wallet.Encrypted as CC
 import qualified Data.ByteArray as BA
 import qualified Data.ByteString as BS
 import qualified Data.Text as T
@@ -722,3 +729,61 @@ hex = convertToBase Base16
 -- | Decode a 'ByteString' from base16
 fromHex :: ByteArray bout => ByteString -> Either String bout
 fromHex = convertFromBase Base16
+
+data ErrUnXPrvStripPub
+    = ErrNoRoundtripMismatch
+      -- ^ The resulting bytestring would have been unable to roundtrip using
+      -- @xPrvFromStrippedPubXPrv@. Most likely because the input @XPrv@ was
+      -- encrypted.
+    | ErrUnexpectedRoundtripError
+      -- ^ Something unexpected went wrong.
+    deriving (Eq, Show)
+
+-- | Extracts the raw xprv bytes as @private key <> chain code@, i.e. without
+-- the public key.
+--
+-- Returns @Left@ if the resulting bytestring fails to roundtrip. Most likely
+-- because the provided key was encrypted.
+unXPrvStripPub :: XPrv -> Either ErrUnXPrvStripPub ByteString
+unXPrvStripPub k = do
+    let res = stripPub . unXPrv $ k
+
+    -- Check that it roundtrips.
+    case (fmap unXPrv . xPrvFromStrippedPubXPrv $ res) of
+            Right bytes
+                | bytes == unXPrv k -> Right res
+                | otherwise         -> Left ErrNoRoundtripMismatch
+            Left  _                 -> Left ErrUnexpectedRoundtripError
+  where
+    -- Converts  prv <> pub <> cc
+    -- To        prv <>        cc
+    stripPub :: ByteString -> ByteString
+    stripPub xprv' = prv <> chainCode
+      where
+        (prv, rest) = BS.splitAt 64 xprv'
+        (_pub, chainCode) = BS.splitAt 32 rest
+
+data ErrXPrvFromStrippedPubXPrv
+    = ErrInputLengthMismatch Int Int -- ^ Expected, Actual
+    | ErrInternalError String
+    deriving (Eq, Show)
+
+-- Create a @XPrv@ from a prv <> cc bytestring.
+xPrvFromStrippedPubXPrv :: ByteString -> Either ErrXPrvFromStrippedPubXPrv XPrv
+xPrvFromStrippedPubXPrv x =
+    let
+        res = toXPrv $ CC.encryptedCreateDirectWithTweak x pass
+    in
+        if BS.length x == expectedInputLength
+        then res
+        else Left $ ErrInputLengthMismatch expectedInputLength (BS.length x)
+  where
+    pass :: ByteString
+    pass = ""
+
+    expectedInputLength = 96
+
+    -- @xprv@ can fail. But because it is calling @encryptedKey@ internally,
+    -- and we are feeding it the output of @unEncryptedKey@, it really shouldn't.
+    toXPrv :: CC.EncryptedKey -> Either ErrXPrvFromStrippedPubXPrv XPrv
+    toXPrv = left ErrInternalError . xprv . CC.unEncryptedKey

lib/core/test/unit/Cardano/Wallet/Primitive/AddressDerivationSpec.hs

@@ -25,6 +25,7 @@ import Cardano.Wallet.Gen
 import Cardano.Wallet.Primitive.AddressDerivation
     ( Depth (..)
     , DerivationType (..)
+    , ErrUnXPrvStripPub (..)
     , ErrWrongPassphrase (..)
     , FromMnemonic (..)
     , FromMnemonicError (..)
@@ -42,6 +43,8 @@ import Cardano.Wallet.Primitive.AddressDerivation
     , checkPassphrase
     , encryptPassphrase
     , getIndex
+    , unXPrvStripPub
+    , xPrvFromStrippedPubXPrv
     )
 import Cardano.Wallet.Primitive.AddressDerivation.Byron
     ( ByronKey (..) )
@@ -51,12 +54,16 @@ import Cardano.Wallet.Primitive.AddressDerivation.Shelley
     ( KnownNetwork (..), ShelleyKey (..) )
 import Cardano.Wallet.Primitive.Types
     ( Address (..), Hash (..) )
+import Control.Arrow
+    ( left )
 import Control.Monad
-    ( replicateM )
+    ( replicateM, (>=>) )
 import Control.Monad.IO.Class
     ( liftIO )
 import Data.Either
-    ( isRight )
+    ( isLeft, isRight )
+import Data.Function
+    ( (&) )
 import Data.Proxy
     ( Proxy (..) )
 import Test.Hspec
@@ -65,12 +72,16 @@ import Test.QuickCheck
     ( Arbitrary (..)
     , Gen
     , InfiniteList (..)
+    , NonNegative (..)
     , Property
     , arbitraryBoundedEnum
     , arbitraryPrintableChar
     , choose
+    , classify
+    , counterexample
     , expectFailure
     , genericShrink
+    , label
     , oneof
     , property
     , vectorOf
@@ -214,6 +225,13 @@ spec = do
         it "XPub IcarusKey"
             (property $ prop_roundtripXPub @IcarusKey)
 
+    describe "unXPrvStripPub & xPrvFromStrippedPubXPrv" $ do
+        it "either roundtrips or fails (if xprv is encrypted)"
+            (property prop_unXPrvStripRoundtrip)
+
+        it "(xPrvFromStrippedPubXPrv bs) fails if (BS.length bs) /= 96"
+            (property prop_xPrvFromStrippedPubXPrvLengthRequirement)
+
 {-------------------------------------------------------------------------------
                                Properties
 -------------------------------------------------------------------------------}
@@ -282,6 +300,47 @@ prop_passphraseHashMalformed
 prop_passphraseHashMalformed pwd = monadicIO $ liftIO $ do
     checkPassphrase pwd (Hash mempty) `shouldBe` Left ErrWrongPassphrase
 
+-- NOTE: Instead of testing
+-- > encrypted => fails
+-- we are testing
+-- > fails => encrypted
+--
+-- This /should/ be enough. If a key were to be encrypted, but still roundtrip,
+-- we would not care.
+prop_unXPrvStripRoundtrip :: XPrvWithPass -> Property
+prop_unXPrvStripRoundtrip (XPrvWithPass k enc) = do
+    let res = unXPrvStripPub k
+    case res of
+        Right k' ->
+            xPrvFromStrippedPubXPrv k' === Right k
+                & label "roundtrip"
+        Left ErrNoRoundtripMismatch ->
+            enc /= Passphrase ""
+                & label "mismatch"
+                & counterexample "XPrv should be encrypted for the roundtrip to\
+                                 \fail"
+        Left ErrUnexpectedRoundtripError ->
+            counterexample "unexpected error" $ property False
+
+prop_xPrvFromStrippedPubXPrvLengthRequirement
+    :: Unencrypted XPrv
+    -> NonNegative Int
+    -> Property
+prop_xPrvFromStrippedPubXPrvLengthRequirement (Unencrypted k) (NonNegative n) = do
+    let f = toStripped >=> (return . BS.take n) >=> fromStripped
+    let k' = f k
+    -- A reason for writing the test using BS.take n instead of say vectorOf
+    -- was guarding against
+    -- https://github.com/input-output-hk/cardano-crypto/issues/67
+    n < 96 ==> property $ isLeft k'
+        & counterexample ("n = " ++ show n)
+        & counterexample ("result = " ++ show k')
+        & classify (n == 96) "== 96"
+        & classify (n < 96) "< 96"
+  where
+    toStripped = left show . unXPrvStripPub
+    fromStripped = left show . xPrvFromStrippedPubXPrv
+
 {-------------------------------------------------------------------------------
                              Arbitrary Instances
 -------------------------------------------------------------------------------}
@@ -343,49 +402,84 @@ instance Eq XPrv where
 
 instance Arbitrary (ShelleyKey 'RootK XPrv) where
     shrink _ = []
-    arbitrary = genRootKeysSeq
+    arbitrary = genRootKeysSeqWithPass =<< genPassphrase (0, 16)
 
 instance Arbitrary (ShelleyKey 'AccountK XPub) where
     shrink _ = []
-    arbitrary = publicKey <$> genRootKeysSeq
+    arbitrary = publicKey <$> (genRootKeysSeqWithPass =<< genPassphrase (0, 16))
 
 instance Arbitrary (ShelleyKey 'RootK XPub) where
     shrink _ = []
     arbitrary = publicKey <$> arbitrary
 
 instance Arbitrary (ByronKey 'RootK XPrv) where
     shrink _ = []
-    arbitrary = genRootKeysRnd
+    arbitrary = genRootKeysRndWithPass =<< genPassphrase (0, 16)
 
 instance Arbitrary (IcarusKey 'RootK XPrv) where
     shrink _ = []
-    arbitrary = genRootKeysIca
+    arbitrary = genRootKeysIcaWithPass =<< genPassphrase (0, 16)
 
 instance Arbitrary (IcarusKey 'AccountK XPub) where
     shrink _ = []
-    arbitrary = publicKey <$> genRootKeysIca
+    arbitrary = publicKey <$> (genRootKeysIcaWithPass =<< genPassphrase (0, 16))
 
 instance Arbitrary NetworkDiscriminant where
     arbitrary = arbitraryBoundedEnum
     shrink = genericShrink
 
-genRootKeysSeq :: Gen (ShelleyKey depth XPrv)
-genRootKeysSeq = do
-    (s, g, e) <- (,,)
-        <$> (SomeMnemonic <$> genMnemonic @15)
-        <*> (Just . SomeMnemonic <$> genMnemonic @12)
-        <*> genPassphrase @"encryption" (0, 16)
-    return $ Seq.unsafeGenerateKeyFromSeed (s, g) e
+newtype Unencrypted a = Unencrypted { getUnencrypted :: a }
+    deriving (Eq, Show)
+
+instance Arbitrary (Unencrypted XPrv) where
+    shrink _ = []
+    arbitrary = Unencrypted <$> genAnyKeyWithPass mempty
+
+data XPrvWithPass = XPrvWithPass XPrv (Passphrase "encryption")
+    deriving (Eq, Show)
+
+instance Arbitrary XPrvWithPass where
+    shrink _ = []
+    arbitrary = do
+        pwd <- oneof
+            [ genPassphrase (0, 16)
+            , return $ Passphrase ""
+            ]
+        flip XPrvWithPass pwd <$> genAnyKeyWithPass pwd
+
+genAnyKeyWithPass
+    :: Passphrase "encryption"
+    -> Gen XPrv
+genAnyKeyWithPass pwd = oneof
+    [ getRawKey
+        <$> genRootKeysSeqWithPass pwd
+    , getRawKey
+        <$> genRootKeysRndWithPass pwd
+    , getRawKey
+        <$> genRootKeysIcaWithPass pwd
+    ]
 
-genRootKeysRnd :: Gen (ByronKey 'RootK XPrv)
-genRootKeysRnd = Rnd.generateKeyFromSeed
+genRootKeysSeqWithPass
+    :: Passphrase "encryption"
+    -> Gen (ShelleyKey depth XPrv)
+genRootKeysSeqWithPass encryptionPass = do
+    s <- SomeMnemonic <$> genMnemonic @15
+    g <- Just . SomeMnemonic <$> genMnemonic @12
+    return $ Seq.unsafeGenerateKeyFromSeed (s, g) encryptionPass
+
+genRootKeysRndWithPass
+    :: Passphrase "encryption"
+    -> Gen (ByronKey 'RootK XPrv)
+genRootKeysRndWithPass encryptionPass = Rnd.generateKeyFromSeed
     <$> (SomeMnemonic <$> genMnemonic @12)
-    <*> genPassphrase @"encryption" (0, 16)
+    <*> (pure encryptionPass)
 
-genRootKeysIca :: Gen (IcarusKey depth XPrv)
-genRootKeysIca = Ica.unsafeGenerateKeyFromSeed
+genRootKeysIcaWithPass
+    :: Passphrase "encryption"
+    -> Gen (IcarusKey depth XPrv)
+genRootKeysIcaWithPass encryptionPass = Ica.unsafeGenerateKeyFromSeed
     <$> (SomeMnemonic <$> genMnemonic @15)
-    <*> genPassphrase @"encryption" (0, 16)
+    <*> (pure encryptionPass)
 
 genPassphrase :: (Int, Int) -> Gen (Passphrase purpose)
 genPassphrase range = do

lib/jormungandr/cardano-wallet-jormungandr.cabal

@@ -251,10 +251,11 @@ test-suite integration
       Test.Integration.Jormungandr.Scenario.API.StakePools
       Test.Integration.Jormungandr.Scenario.API.Transactions
       Test.Integration.Jormungandr.Scenario.CLI.Launcher
+      Test.Integration.Jormungandr.Scenario.CLI.Keys
+      Test.Integration.Jormungandr.Scenario.CLI.Mnemonics
       Test.Integration.Jormungandr.Scenario.CLI.Server
       Test.Integration.Jormungandr.Scenario.CLI.StakePools
       Test.Integration.Jormungandr.Scenario.CLI.Transactions
-      Test.Integration.Jormungandr.Scenario.CLI.Mnemonics
       Test.Utils.Ports
 
 benchmark latency

lib/jormungandr/test/integration/Main.hs

@@ -84,6 +84,7 @@ import qualified Cardano.Wallet.Jormungandr.NetworkSpec as NetworkLayer
 import qualified Data.Text as T
 import qualified Test.Integration.Jormungandr.Scenario.API.StakePools as StakePoolsApiJormungandr
 import qualified Test.Integration.Jormungandr.Scenario.API.Transactions as TransactionsApiJormungandr
+import qualified Test.Integration.Jormungandr.Scenario.CLI.Keys as KeysCLI
 import qualified Test.Integration.Jormungandr.Scenario.CLI.Launcher as LauncherCLI
 import qualified Test.Integration.Jormungandr.Scenario.CLI.Mnemonics as MnemonicsJormungandr
 import qualified Test.Integration.Jormungandr.Scenario.CLI.Server as ServerCLI
@@ -117,6 +118,7 @@ main = withUtf8Encoding $ withLogging Nothing Info $ \(_, tr) -> do
             describe "Miscellaneous CLI tests" $ parallel (MiscellaneousCLI.spec @t)
             describe "Launcher CLI tests" $ parallel (LauncherCLI.spec @t)
             describe "Stake Pool Metrics" MetricsSpec.spec
+            describe "Key CLI tests" KeysCLI.spec
 
         describe "API Specifications" $ specWithServer tr $ do
             Addresses.spec