never executed always true always false

    1 {-# LANGUAGE FlexibleContexts #-}
    2 {-# LANGUAGE NamedFieldPuns #-}
    3 
    4 {-# OPTIONS_HADDOCK hide #-}
    5 {-# OPTIONS_GHC -fno-warn-deprecations #-}
    6 
    7 module Command.Address.Bootstrap
    8     ( Cmd
    9     , mod
   10     , run
   11     ) where
   12 
   13 import Prelude hiding
   14     ( mod )
   15 
   16 import Cardano.Address
   17     ( AddressDiscrimination (..), NetworkDiscriminant, base58 )
   18 import Cardano.Address.Derivation
   19     ( XPub, coerceWholeDomainIndex )
   20 import Cardano.Address.Style.Byron
   21     ( Byron )
   22 import Options.Applicative
   23     ( CommandFields
   24     , Mod
   25     , command
   26     , footerDoc
   27     , header
   28     , helper
   29     , info
   30     , optional
   31     , progDesc
   32     )
   33 import Options.Applicative.Derivation
   34     ( DerivationPath, castDerivationPath, derivationPathArg, xpubOpt )
   35 import Options.Applicative.Discrimination
   36     ( NetworkTag (..), networkTagOpt )
   37 import Options.Applicative.Help.Pretty
   38     ( bold, indent, string, vsep )
   39 import Options.Applicative.Style
   40     ( Style (..) )
   41 import System.IO
   42     ( stdin, stdout )
   43 import System.IO.Extra
   44     ( hGetXPub, progName )
   45 
   46 import qualified Cardano.Address.Style.Byron as Byron
   47 import qualified Cardano.Address.Style.Icarus as Icarus
   48 import qualified Cardano.Codec.Bech32.Prefixes as CIP5
   49 import qualified Data.ByteString.Char8 as B8
   50 import qualified Data.Text.Encoding as T
   51 
   52 data Cmd = Cmd
   53     { rootXPub :: Maybe XPub
   54     , networkTag :: NetworkTag
   55     , derivationPath :: Maybe DerivationPath
   56     } deriving (Show)
   57 
   58 mod :: (Cmd -> parent) -> Mod CommandFields parent
   59 mod liftCmd = command "bootstrap" $
   60     info (helper <*> fmap liftCmd parser) $ mempty
   61         <> progDesc "Create a bootstrap address"
   62         <> header "Those addresses, now deprecated, were used during the Byron era."
   63         <> footerDoc (Just $ vsep
   64             [ string "Example:"
   65             , indent 2 $ bold $ string $ "$ "<>progName<>" recovery-phrase generate --size 12 \\"
   66             , indent 4 $ bold $ string $ "| "<>progName<>" key from-recovery-phrase Byron > root.prv"
   67             , indent 2 $ string ""
   68             , indent 2 $ bold $ string "$ cat root.prv \\"
   69             , indent 4 $ bold $ string $ "| "<>progName<>" key child 14H/42H | tee addr.prv \\"
   70             , indent 4 $ bold $ string $ "| "<>progName<>" key public --with-chain-code \\"
   71             , indent 4 $ bold $ string $ "| "<>progName<>" address bootstrap --root $(cat root.prv | "<>progName<>" key public --with-chain-code) \\"
   72             , indent 8 $ bold $ string "--network-tag preview 14H/42H"
   73             , indent 2 $ string "KjgoiXJS2coBYYTM69pafiau6bbGqKrzbFiRzahpWsPvit48YNiHocPpB7VJ..."
   74             ])
   75   where
   76     parser = Cmd
   77         <$> optional (xpubOpt [CIP5.root_xvk] "root" "A root public key. Needed for Byron addresses only.")
   78         <*> networkTagOpt Byron
   79         <*> optional derivationPathArg
   80 
   81 run :: Cmd -> IO ()
   82 run Cmd{networkTag,rootXPub,derivationPath} = do
   83     (_hrp, xpub) <- hGetXPub stdin [CIP5.addr_xvk]
   84     addr <- case derivationPath of
   85         Nothing ->
   86             pure $ Icarus.paymentAddress discriminant (Icarus.liftXPub xpub)
   87         Just untypedPath -> do
   88             root <- maybe
   89                 (fail "A root public key must be provided when --path is provided") pure rootXPub
   90             case castDerivationPath untypedPath of
   91                 [acctIx, addrIx] -> do
   92                     let path = (acctIx, coerceWholeDomainIndex addrIx)
   93                         xkey = Byron.liftXPub root path xpub
   94                     pure $ Byron.paymentAddress discriminant xkey
   95                 _ -> do
   96                     fail "Byron derivation path must describe 2 levels (e.g. 0H/0H)"
   97     B8.hPutStr stdout $ T.encodeUtf8 $ base58 addr
   98   where
   99     discriminant :: NetworkDiscriminant Byron -- Or Icarus, same.
  100     discriminant
  101         | networkTag == snd Byron.byronMainnet =
  102             Byron.byronMainnet
  103         | otherwise =
  104             (RequiresNetworkTag, networkTag)