never executed always true always false
    1 {-# LANGUAGE FlexibleContexts #-}
    2 {-# LANGUAGE LambdaCase #-}
    3 {-# LANGUAGE NamedFieldPuns #-}
    4 {-# LANGUAGE OverloadedStrings #-}
    5 {-# LANGUAGE TupleSections #-}
    6 
    7 {-# OPTIONS_HADDOCK hide #-}
    8 
    9 module Command.Key.Child
   10     ( Cmd (..)
   11     , mod
   12     , run
   13     ) where
   14 
   15 import Prelude hiding
   16     ( mod )
   17 
   18 import Cardano.Address.Derivation
   19     ( DerivationScheme (..)
   20     , deriveXPrv
   21     , deriveXPub
   22     , indexToWord32
   23     , xprvToBytes
   24     , xpubToBytes
   25     )
   26 import Codec.Binary.Encoding
   27     ( AbstractEncoding (..) )
   28 import Control.Monad
   29     ( foldM )
   30 import Data.Functor.Identity
   31     ( Identity (..) )
   32 import Options.Applicative
   33     ( CommandFields, Mod, command, footerDoc, helper, info, progDesc )
   34 import Options.Applicative.Derivation
   35     ( DerivationPath, castDerivationPath, derivationPathArg )
   36 import Options.Applicative.Help.Pretty
   37     ( string )
   38 import System.IO
   39     ( stdin, stdout )
   40 import System.IO.Extra
   41     ( hGetXP__, hPutBytes )
   42 
   43 import qualified Cardano.Codec.Bech32.Prefixes as CIP5
   44 
   45 newtype Cmd = Child
   46     { path :: DerivationPath
   47     } deriving (Show)
   48 
   49 mod :: (Cmd -> parent) -> Mod CommandFields parent
   50 mod liftCmd = command "child" $
   51     info (helper <*> fmap liftCmd parser) $ mempty
   52         <> progDesc "Derive child keys from a parent public/private key"
   53         <> footerDoc (Just $ string $ mconcat
   54             [ "The parent key is read from stdin."
   55             ])
   56   where
   57     parser = Child
   58         <$> derivationPathArg
   59 
   60 run :: Cmd -> IO ()
   61 run Child{path} = do
   62     (hrp, child) <- hGetXP__ stdin allowedPrefixes >>= \case
   63         Left (hrp, xpub) -> do
   64             let ixs = castDerivationPath path
   65             case foldM (deriveXPub DerivationScheme2) xpub ixs of
   66                 Just child ->
   67                     (,xpubToBytes child) <$> childHrpFor (indexToWord32 <$> ixs) hrp
   68                 Nothing ->
   69                     fail
   70                         "Couldn't derive child key. If you're trying to derive \
   71                         \children on a PUBLIC key, you must use soft indexes only."
   72 
   73         Right (hrp, xprv) -> do
   74             let ixs = castDerivationPath path
   75             let scheme = if length ixs == 2 && hrp == CIP5.root_xsk
   76                     then DerivationScheme1
   77                     else DerivationScheme2
   78             let Identity child = foldM (\k -> pure . deriveXPrv scheme k) xprv ixs
   79             (,xprvToBytes child) <$> childHrpFor (indexToWord32 <$> ixs) hrp
   80 
   81     hPutBytes stdout child (EBech32 hrp)
   82   where
   83     allowedPrefixes =
   84         [ CIP5.root_xsk
   85         , CIP5.acct_xsk
   86         , CIP5.acct_xvk
   87         , CIP5.root_shared_xsk
   88         , CIP5.acct_shared_xsk
   89         , CIP5.acct_shared_xvk
   90         ]
   91 
   92     -- As a reminder, we really have two scenarios:
   93     --
   94     -- Byron Legacy:
   95     --
   96     --     m / rnd_account' / rnd_address'
   97     --
   98     --
   99     -- Icarus & Shelley:
  100     --
  101     --     m / purpose' / coin_type' / account' / role / index
  102     --
  103     -- We do not allow derivations to anywhere in the path to avoid people
  104     -- shooting themselves in the foot.
  105     -- Hence We only allow the following transformations:
  106     --
  107     -- root_xsk => addr_xsk: (legacy)
  108     --     m => m / rnd_account' / rnd_address
  109     --
  110     -- root_xsk => acct_xsk: (hard derivation from root to account)
  111     --     m => m / purpose' / coin_type' / account'
  112     --
  113     -- root_xsk => acct_xsk: (hard derivation from root to address)
  114     --     m => m / purpose' / coin_type' / account' / role / index
  115     --
  116     -- purpose' = 1852H for shelley wallet addresses.
  117     -- purpose' = 1854H for shelley wallet addresses that expose shared account.
  118     --
  119     -- acct_xsk => addr_xsk: (hard derivation from account to address)
  120     --     m / purpose' / coin_type' / account' => m / purpose' / coin_type' / account' / role / index
  121     --
  122     -- acct_xvk => addr_xvk: (soft derivation from account to address)
  123     --     m / purpose' / coin_type' / account' => m / purpose' / coin_type' / account' / role / index
  124     --
  125     --
  126 
  127     -- Shared:
  128     --
  129     --     m / purpose' / coin_type' / account' / role / index
  130     --
  131     -- purpose' = 1854H for shared wallet addresses.
  132     --
  133     -- As with Icarus/Shelley sequential wallets, to prevent undiscoverable
  134     -- addresses, we allow only the following transformations:
  135     --
  136     -- shared_root_xsk => shared_acct_xsk: (hard derivation from root to account)
  137     --     m => m / purpose' / coin_type' / account'
  138     --
  139     -- shared_root_xsk => shared_acct_xsk: (hard derivation from root to address)
  140     --     m => m / purpose' / coin_type' / account' / role / index
  141     --
  142     -- shared_acct_xsk => shared_addr_xsk: (hard derivation from account to address)
  143     --     m / purpose' / coin_type' / account' => m / purpose' / coin_type' / account' / role / index
  144     --
  145     -- shared_acct_xvk => shared_addr_xvk: (soft derivation from account to address)
  146     --     m / purpose' / coin_type' / account' => m / purpose' / coin_type' / account' / role / index
  147     --
  148     --
  149     -- There's no use-case at the moment for accessing intermediate paths such
  150     -- as m / purpose' or m / purpose' / coin_type' so we do not expose them.
  151     childHrpFor [_,_,_,2,_] hrp
  152         | hrp == CIP5.root_xsk = pure CIP5.stake_xsk
  153         | hrp == CIP5.root_shared_xsk = pure CIP5.stake_shared_xsk
  154 
  155     childHrpFor [p,_,_,_,_] hrp
  156         | hrp == CIP5.root_xsk =
  157               -- 2147485502 stands for 1854H
  158               if p == 2147485502 then
  159                   pure CIP5.addr_shared_xsk
  160               else
  161                   pure CIP5.addr_xsk
  162         | hrp == CIP5.root_shared_xsk = pure CIP5.addr_shared_xsk
  163 
  164     childHrpFor [p,_,_] hrp
  165         | hrp == CIP5.root_xsk =
  166               -- 2147485502 stands for 1854H
  167               if p == 2147485502 then
  168                   pure CIP5.acct_shared_xsk
  169               -- 2147485503 stands for 1855H
  170               else if p == 2147485503 then
  171                   pure CIP5.policy_xsk
  172               else
  173                   pure CIP5.acct_xsk
  174         | hrp == CIP5.root_shared_xsk = pure CIP5.acct_shared_xsk
  175 
  176     childHrpFor [2,_] hrp
  177         | hrp == CIP5.acct_xsk = pure CIP5.stake_xsk
  178         | hrp == CIP5.acct_xvk = pure CIP5.stake_xvk
  179         | hrp == CIP5.acct_shared_xsk = pure CIP5.stake_shared_xsk
  180         | hrp == CIP5.acct_shared_xvk = pure CIP5.stake_shared_xvk
  181 
  182     childHrpFor [_,_] hrp
  183         | hrp == CIP5.root_xsk = pure CIP5.addr_xsk
  184         | hrp == CIP5.acct_xsk = pure CIP5.addr_xsk
  185         | hrp == CIP5.acct_xvk = pure CIP5.addr_xvk
  186         | hrp == CIP5.acct_shared_xsk = pure CIP5.addr_shared_xsk
  187         | hrp == CIP5.acct_shared_xvk = pure CIP5.addr_shared_xvk
  188 
  189     childHrpFor _ hrp
  190         | hrp == CIP5.root_xsk = fail
  191             "When deriving child keys from a parent root key, you must \
  192             \provide either 2, 3 or 5 path segments. Provide 2 (account and \
  193             \address) if you intend to derive a legacy Byron key. Provide 3 or 5 \
  194             \(purpose, coin_type, account, role, index) if you're dealing with \
  195             \anything else."
  196 
  197         | hrp == CIP5.root_shared_xsk = fail
  198             "When deriving child keys from a parent root key, you must \
  199             \provide either 3 or 5 path segments. Provide 3 \
  200             \(purpose, coin_type, account) or 5 \
  201             \(purpose, coin_type, account, role, index)."
  202 
  203         | otherwise = fail
  204             "When deriving child keys from a parent account key, you must \
  205             \provide exactly two path segments (role & index)."