{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_HADDOCK hide #-}
-- |
-- Copyright: 2020 Input Output (Hong Kong) Ltd., 2021-2022 Input Output Global Inc. (IOG), 2023-2025 Intersect
-- License: Apache-2.0
module Command.Key.Child
( Cmd (..)
, mod
, run
) where
import Prelude hiding
( mod )
import Cardano.Address.Derivation
( DerivationScheme (..)
, deriveXPrv
, deriveXPub
, indexToWord32
, xprvToBytes
, xpubToBytes
)
import Codec.Binary.Encoding
( AbstractEncoding (..) )
import Control.Monad
( foldM )
import Data.Functor.Identity
( Identity (..) )
import Data.Text
( Text )
import Options.Applicative
( CommandFields, Mod, command, footerDoc, helper, info, progDesc )
import Options.Applicative.Derivation
( DerivationPath, castDerivationPath, derivationPathArg )
import Options.Applicative.Help.Pretty
( Doc, pretty )
import System.IO
( stdin, stdout )
import System.IO.Extra
( hGetXP__, hPutBytes )
import qualified Cardano.Codec.Bech32.Prefixes as CIP5
newtype Cmd = Child
{ path :: DerivationPath
} deriving (Show)
mod :: (Cmd -> parent) -> Mod CommandFields parent
mod liftCmd = command "child" $
info (helper <*> fmap liftCmd parser) $ mempty
<> progDesc "Derive child keys from a parent public/private key"
<> footerDoc (Just $ prettyText $ mconcat
[ "The parent key is read from stdin."
])
where
parser = Child
<$> derivationPathArg
prettyText :: Text -> Doc
prettyText = pretty
run :: Cmd -> IO ()
run Child{path} = do
(hrp, child) <- hGetXP__ stdin allowedPrefixes >>= \case
Left (hrp, xpub) -> do
let ixs = castDerivationPath path
case foldM (deriveXPub DerivationScheme2) xpub ixs of
Just child ->
(,xpubToBytes child) <$> childHrpFor (indexToWord32 <$> ixs) hrp
Nothing ->
fail
"Couldn't derive child key. If you're trying to derive \
\children on a PUBLIC key, you must use soft indexes only."
Right (hrp, xprv) -> do
let ixs = castDerivationPath path
let scheme = if length ixs == 2 && hrp == CIP5.root_xsk
then DerivationScheme1
else DerivationScheme2
let Identity child = foldM (\k -> pure . deriveXPrv scheme k) xprv ixs
(,xprvToBytes child) <$> childHrpFor (indexToWord32 <$> ixs) hrp
hPutBytes stdout child (EBech32 hrp)
where
allowedPrefixes =
[ CIP5.root_xsk
, CIP5.acct_xsk
, CIP5.acct_xvk
, CIP5.root_shared_xsk
, CIP5.acct_shared_xsk
, CIP5.acct_shared_xvk
]
-- As a reminder, we really have two scenarios:
--
-- Byron Legacy:
--
-- m / rnd_account' / rnd_address'
--
--
-- Icarus & Shelley:
--
-- m / purpose' / coin_type' / account' / role / index
--
-- purpose' = 1852H for shelley wallet addresses.
--
-- We do not allow derivations to anywhere in the path to avoid people
-- shooting themselves in the foot.
-- Hence We only allow the following transformations:
--
-- root_xsk => addr_xsk: (legacy)
-- m => m / rnd_account' / rnd_address
--
-- root_xsk => acct_xsk: (hard derivation from root to account)
-- m => m / purpose' / coin_type' / account'
--
-- root_xsk => acct_xsk: (hard derivation from root to address)
-- m => m / purpose' / coin_type' / account' / role / index
--
-- acct_xsk => addr_xsk: (hard derivation from account to address)
-- m / purpose' / coin_type' / account' => m / purpose' / coin_type' / account' / role / index
--
-- acct_xvk => addr_xvk: (soft derivation from account to address)
-- m / purpose' / coin_type' / account' => m / purpose' / coin_type' / account' / role / index
--
--
-- Shared:
--
-- m / purpose' / coin_type' / account' / role / index
--
-- purpose' = 1854H for shared wallet addresses.
--
-- As with Icarus/Shelley sequential wallets, to prevent undiscoverable
-- addresses, we allow only the following transformations:
--
-- shared_root_xsk => shared_acct_xsk: (hard derivation from root to account)
-- m => m / purpose' / coin_type' / account'
--
-- shared_root_xsk => shared_acct_xsk: (hard derivation from root to address)
-- m => m / purpose' / coin_type' / account' / role / index
--
-- shared_acct_xsk => shared_addr_xsk: (hard derivation from account to address)
-- m / purpose' / coin_type' / account' => m / purpose' / coin_type' / account' / role / index
--
-- shared_acct_xvk => shared_addr_xvk: (soft derivation from account to address)
-- m / purpose' / coin_type' / account' => m / purpose' / coin_type' / account' / role / index
--
--
-- There's no use-case at the moment for accessing intermediate paths such
-- as m / purpose' or m / purpose' / coin_type' so we do not expose them.
childHrpFor [_,_,_,2,_] hrp
| hrp == CIP5.root_xsk = pure CIP5.stake_xsk
| hrp == CIP5.root_shared_xsk = pure CIP5.stake_shared_xsk
childHrpFor [_,_,_,3,0] hrp
| hrp == CIP5.root_xsk = pure CIP5.drep_xsk
childHrpFor [_,_,_,4,0] hrp
| hrp == CIP5.root_xsk = pure CIP5.cc_cold_xsk
childHrpFor [_,_,_,5,0] hrp
| hrp == CIP5.root_xsk = pure CIP5.cc_hot_xsk
childHrpFor [p,_,_,_,_] hrp
| hrp == CIP5.root_xsk =
-- 2147485502 stands for 1854H
if p == 2147485502 then
pure CIP5.addr_shared_xsk
else
pure CIP5.addr_xsk
| hrp == CIP5.root_shared_xsk = pure CIP5.addr_shared_xsk
childHrpFor [p,_,_] hrp
| hrp == CIP5.root_xsk =
-- 2147485502 stands for 1854H
if p == 2147485502 then
pure CIP5.acct_shared_xsk
-- 2147485503 stands for 1855H
else if p == 2147485503 then
pure CIP5.policy_xsk
else
pure CIP5.acct_xsk
| hrp == CIP5.root_shared_xsk = pure CIP5.acct_shared_xsk
childHrpFor [2,_] hrp
| hrp == CIP5.acct_xsk = pure CIP5.stake_xsk
| hrp == CIP5.acct_xvk = pure CIP5.stake_xvk
| hrp == CIP5.acct_shared_xsk = pure CIP5.stake_shared_xsk
| hrp == CIP5.acct_shared_xvk = pure CIP5.stake_shared_xvk
childHrpFor [3,0] hrp
| hrp == CIP5.acct_xsk = pure CIP5.drep_xsk
| hrp == CIP5.acct_xvk = pure CIP5.drep_xvk
childHrpFor [4,0] hrp
| hrp == CIP5.acct_xsk = pure CIP5.cc_cold_xsk
| hrp == CIP5.acct_xvk = pure CIP5.cc_cold_xvk
childHrpFor [5,0] hrp
| hrp == CIP5.acct_xsk = pure CIP5.cc_hot_xsk
| hrp == CIP5.acct_xvk = pure CIP5.cc_hot_xvk
childHrpFor [_,_] hrp
| hrp == CIP5.root_xsk = pure CIP5.addr_xsk
| hrp == CIP5.acct_xsk = pure CIP5.addr_xsk
| hrp == CIP5.acct_xvk = pure CIP5.addr_xvk
| hrp == CIP5.acct_shared_xsk = pure CIP5.addr_shared_xsk
| hrp == CIP5.acct_shared_xvk = pure CIP5.addr_shared_xvk
childHrpFor _ hrp
| hrp == CIP5.root_xsk = fail
"When deriving child keys from a parent root key, you must \
\provide either 2, 3 or 5 path segments. Provide 2 (account and \
\address) if you intend to derive a legacy Byron key. Provide 3 or 5 \
\(purpose, coin_type, account, role, index) if you're dealing with \
\anything else."
| hrp == CIP5.root_shared_xsk = fail
"When deriving child keys from a parent root key, you must \
\provide either 3 or 5 path segments. Provide 3 \
\(purpose, coin_type, account) or 5 \
\(purpose, coin_type, account, role, index)."
| otherwise = fail
"When deriving child keys from a parent account key, you must \
\provide exactly two path segments (role & index)."