never executed always true always false

    1 {-# LANGUAGE FlexibleContexts #-}
    2 {-# LANGUAGE NamedFieldPuns #-}
    3 {-# LANGUAGE OverloadedStrings #-}
    4 
    5 {-# OPTIONS_HADDOCK hide #-}
    6 
    7 module Command.Key.Hash
    8     ( Cmd (..)
    9     , mod
   10     , run
   11     ) where
   12 
   13 import Prelude hiding
   14     ( mod )
   15 
   16 import Cardano.Address.Derivation
   17     ( hashCredential )
   18 import Codec.Binary.Encoding
   19     ( AbstractEncoding (..) )
   20 import Control.Monad
   21     ( when )
   22 import Data.Maybe
   23     ( fromJust )
   24 import Options.Applicative
   25     ( CommandFields, Mod, command, footerDoc, helper, info, progDesc )
   26 import Options.Applicative.Format
   27     ( FormatType (..), formatOpt )
   28 import Options.Applicative.Help.Pretty
   29     ( string )
   30 import System.IO
   31     ( stdin, stdout )
   32 import System.IO.Extra
   33     ( hGetBech32, hPutBytes )
   34 
   35 import qualified Cardano.Codec.Bech32.Prefixes as CIP5
   36 import qualified Data.ByteString as BS
   37 
   38 newtype Cmd = Hash
   39     { outputFormat :: FormatType
   40     } deriving (Show)
   41 
   42 mod :: (Cmd -> parent) -> Mod CommandFields parent
   43 mod liftCmd = command "hash" $
   44     info (helper <*> fmap liftCmd parser) $ mempty
   45         <> progDesc "Get the hash of a public key"
   46         <> footerDoc (Just $ string $ mconcat
   47             [ "The public key is read from stdin."
   48             , "To get hex-encoded output pass '--hex'."
   49             , "Otherwise bech32-encoded hash is returned."
   50             ])
   51   where
   52     parser = Hash
   53         <$> formatOpt
   54 
   55 run :: Cmd -> IO ()
   56 run Hash{outputFormat} = do
   57     (hrp, bytes) <- hGetBech32 stdin allowedPrefixes
   58     guardBytes hrp bytes
   59     let encoding = case outputFormat of
   60             Hex -> EBase16
   61             Bech32 -> EBech32 $ prefixFor hrp
   62     hPutBytes stdout (hashCredential $ BS.take 32 bytes) encoding
   63   where
   64     -- Mapping of input HRP to output HRP
   65     prefixes =
   66         [ ( CIP5.addr_vk         , CIP5.addr_vkh   )
   67         , ( CIP5.addr_xvk        , CIP5.addr_vkh   )
   68         , ( CIP5.stake_vk        , CIP5.stake_vkh  )
   69         , ( CIP5.stake_xvk       , CIP5.stake_vkh  )
   70         , ( CIP5.addr_shared_vk  , CIP5.addr_shared_vkh )
   71         , ( CIP5.addr_shared_xvk , CIP5.addr_shared_vkh )
   72         , ( CIP5.stake_shared_vk , CIP5.stake_shared_vkh )
   73         , ( CIP5.stake_shared_xvk, CIP5.stake_shared_vkh )
   74         , ( CIP5.policy_vk       , CIP5.policy_vkh  )
   75         , ( CIP5.policy_xvk      , CIP5.policy_vkh  )
   76         ]
   77     allowedPrefixes = map fst prefixes
   78     prefixFor = fromJust . flip lookup prefixes
   79 
   80     guardBytes hrp bytes
   81         | hrp `elem` [CIP5.addr_xvk, CIP5.stake_xvk, CIP5.addr_shared_xvk, CIP5.stake_shared_xvk, CIP5.policy_xvk] = do
   82             when (BS.length bytes /= 64) $
   83                 fail "data should be a 32-byte public key with a 32-byte chain-code appended"
   84 
   85         | otherwise = do
   86             when (BS.length bytes /= 32) $
   87                 fail "data should be a 32-byte public key."