never executed always true always false

    1 {-# LANGUAGE FlexibleContexts #-}
    2 {-# LANGUAGE NamedFieldPuns #-}
    3 {-# LANGUAGE OverloadedStrings #-}
    4 
    5 {-# OPTIONS_HADDOCK hide #-}
    6 {-# OPTIONS_GHC -fno-warn-deprecations #-}
    7 
    8 module Command.Address.Payment
    9     ( Cmd
   10     , mod
   11     , run
   12     ) where
   13 
   14 import Prelude hiding
   15     ( mod )
   16 
   17 import Cardano.Address
   18     ( unAddress )
   19 import Cardano.Address.Derivation
   20     ( pubFromBytes, xpubFromBytes )
   21 import Cardano.Address.Script
   22     ( KeyHash, KeyRole (..), Script, keyHashFromBytes, scriptHashFromBytes )
   23 import Cardano.Address.Style.Shelley
   24     ( Credential (..), shelleyTestnet )
   25 import Codec.Binary.Encoding
   26     ( AbstractEncoding (..) )
   27 import Options.Applicative
   28     ( CommandFields
   29     , Mod
   30     , command
   31     , footerDoc
   32     , header
   33     , helper
   34     , info
   35     , optional
   36     , progDesc
   37     )
   38 import Options.Applicative.Discrimination
   39     ( NetworkTag (..), fromNetworkTag, networkTagOpt )
   40 import Options.Applicative.Help.Pretty
   41     ( bold, indent, string, vsep )
   42 import Options.Applicative.Script
   43     ( scriptArg )
   44 import Options.Applicative.Style
   45     ( Style (..) )
   46 import System.IO
   47     ( stdin, stdout )
   48 import System.IO.Extra
   49     ( hGetBech32, hPutBytes, progName )
   50 
   51 import qualified Cardano.Address.Style.Shelley as Shelley
   52 import qualified Cardano.Codec.Bech32.Prefixes as CIP5
   53 
   54 data Cmd = Cmd
   55     { networkTag :: NetworkTag
   56     , paymentScript :: Maybe (Script KeyHash)
   57     } deriving (Show)
   58 
   59 mod :: (Cmd -> parent) -> Mod CommandFields parent
   60 mod liftCmd = command "payment" $
   61     info (helper <*> fmap liftCmd parser) $ mempty
   62         <> progDesc "Create a payment address"
   63         <> header "Payment addresses carry no delegation rights whatsoever."
   64         <> footerDoc (Just $ vsep
   65             [ string "Example:"
   66             , indent 2 $ bold $ string $ "$ "<>progName<>" recovery-phrase generate --size 15 \\"
   67             , indent 4 $ bold $ string $ "| "<>progName<>" key from-recovery-phrase Shelley > root.prv"
   68             , indent 2 $ string ""
   69             , indent 2 $ bold $ string "$ cat root.prv \\"
   70             , indent 4 $ bold $ string $ "| "<>progName<>" key child 1852H/1815H/0H/0/0 > addr.prv"
   71             , indent 2 $ string ""
   72             , indent 2 $ bold $ string "$ cat addr.prv \\"
   73             , indent 4 $ bold $ string $ "| "<>progName<>" key public --with-chain-code \\"
   74             , indent 4 $ bold $ string $ "| "<>progName<>" address payment --network-tag testnet"
   75             , indent 2 $ string "addr_test1vqrlltfahghjxl5sy5h5mvfrrlt6me5fqphhwjqvj5jd88cccqcek"
   76             ])
   77   where
   78     parser = Cmd
   79         <$> networkTagOpt Shelley
   80         <*> optional scriptArg
   81 
   82 run :: Cmd -> IO ()
   83 run Cmd{networkTag,paymentScript} = do
   84     discriminant <- fromNetworkTag networkTag
   85     addr <- case paymentScript of
   86         Just script -> do
   87             let credential = PaymentFromScript script
   88             pure $ Shelley.paymentAddress discriminant credential
   89         Nothing -> do
   90             (hrp, bytes) <- hGetBech32 stdin allowedPrefixes
   91             addressFromBytes discriminant bytes hrp
   92     hPutBytes stdout (unAddress addr) (EBech32 addrHrp)
   93   where
   94     addrHrp
   95         | networkTag == shelleyTestnet = CIP5.addr_test
   96         | otherwise = CIP5.addr
   97 
   98     allowedPrefixes =
   99         [ CIP5.addr_xvk
  100         , CIP5.addr_vk
  101         , CIP5.addr_vkh
  102         , CIP5.script
  103         ]
  104 
  105     addressFromBytes discriminant bytes hrp
  106         | hrp == CIP5.script = do
  107             case scriptHashFromBytes bytes of
  108                 Nothing ->
  109                     fail "Couldn't convert bytes into script hash."
  110                 Just h  -> do
  111                     let credential = PaymentFromScriptHash h
  112                     pure $ Shelley.paymentAddress discriminant credential
  113 
  114         | hrp == CIP5.addr_vkh = do
  115             case keyHashFromBytes (Payment, bytes) of
  116                 Nothing  ->
  117                     fail "Couldn't convert bytes into payment key hash."
  118                 Just keyhash -> do
  119                     let credential = PaymentFromKeyHash keyhash
  120                     pure $ Shelley.paymentAddress discriminant credential
  121 
  122         | hrp == CIP5.addr_vk = do
  123             case pubFromBytes bytes of
  124                 Nothing  ->
  125                     fail "Couldn't convert bytes into non-extended public key."
  126                 Just key -> do
  127                     let credential = PaymentFromKey $ Shelley.liftPub key
  128                     pure $ Shelley.paymentAddress discriminant credential
  129 
  130         | otherwise = do
  131             case xpubFromBytes bytes of
  132                 Nothing  ->
  133                     fail "Couldn't convert bytes into extended public key."
  134                 Just key -> do
  135                     let credential = PaymentFromExtendedKey $ Shelley.liftXPub key
  136                     pure $ Shelley.paymentAddress discriminant credential