never executed always true always false

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