never executed always true always false
    1 {-# LANGUAGE DataKinds #-}
    2 {-# LANGUAGE DerivingStrategies #-}
    3 {-# LANGUAGE FlexibleContexts #-}
    4 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
    5 {-# LANGUAGE OverloadedStrings #-}
    6 {-# LANGUAGE TypeApplications #-}
    7 
    8 {-# OPTIONS_HADDOCK hide #-}
    9 
   10 module Options.Applicative.Derivation
   11     (
   12     -- * Derivation Path
   13     -- ** Type
   14       DerivationPath
   15     , castDerivationPath
   16     , derivationPathToString
   17     , derivationPathFromString
   18     -- ** Applicative Parser
   19     , derivationPathArg
   20 
   21     -- * Derivation Index
   22     , DerivationIndex
   23     , mkDerivationIndex
   24     , firstHardened
   25     , indexToInteger
   26     , derivationIndexToString
   27     , derivationIndexFromString
   28 
   29     -- * XPub / Pub / XPrv / KeyHash
   30     , xpubReader
   31     , xpubOpt
   32     , xpubArg
   33     , keyhashReader
   34     , pubReader
   35 
   36     -- * Internal
   37     , bech32Reader
   38     ) where
   39 
   40 import Prelude
   41 
   42 import Cardano.Address.Derivation
   43     ( DerivationType (..)
   44     , Index
   45     , Pub
   46     , XPub
   47     , pubFromBytes
   48     , wholeDomainIndex
   49     , xpubFromBytes
   50     )
   51 import Cardano.Address.Script
   52     ( KeyHash (..), KeyRole (..), keyHashFromBytes )
   53 import Codec.Binary.Bech32
   54     ( HumanReadablePart, humanReadablePartToText )
   55 import Codec.Binary.Encoding
   56     ( fromBech32 )
   57 import Control.Arrow
   58     ( left )
   59 import Control.Monad
   60     ( unless )
   61 import Data.ByteString
   62     ( ByteString )
   63 import Data.List
   64     ( intercalate, isSuffixOf )
   65 import Data.Word
   66     ( Word32 )
   67 import Options.Applicative
   68     ( Parser
   69     , argument
   70     , completer
   71     , eitherReader
   72     , help
   73     , listCompleter
   74     , long
   75     , metavar
   76     , option
   77     )
   78 import Safe
   79     ( readEitherSafe )
   80 import System.IO.Extra
   81     ( markCharsRedAtIndices )
   82 
   83 import qualified Data.Text as T
   84 import qualified Data.Text.Encoding as T
   85 
   86 
   87 --
   88 -- Derivation Path
   89 --
   90 
   91 -- | Represent a user-provided 'DerivationPath'.
   92 newtype DerivationPath = DerivationPath [DerivationIndex]
   93     deriving (Show, Eq)
   94 
   95 derivationPathFromString :: String -> Either String DerivationPath
   96 derivationPathFromString str =
   97     DerivationPath
   98         <$> mapM (derivationIndexFromString . T.unpack) (T.splitOn "/" txt)
   99   where
  100     txt = T.pack str
  101 
  102 derivationPathToString :: DerivationPath -> String
  103 derivationPathToString (DerivationPath xs) =
  104     intercalate "/" $ map derivationIndexToString xs
  105 
  106 castDerivationPath :: DerivationPath -> [Index 'WholeDomain depth]
  107 castDerivationPath (DerivationPath xs) = map (wholeDomainIndex . getDerivationIndex) xs
  108 
  109 derivationPathArg :: Parser DerivationPath
  110 derivationPathArg = argument (eitherReader derivationPathFromString) $ mempty
  111     <> metavar "DERIVATION-PATH"
  112     <> help
  113         "Slash-separated derivation path. Hardened indexes are marked with a \
  114         \'H' (e.g. 1852H/1815H/0H/0)."
  115     <> completer (listCompleter ["1852H/1815H/0H/", "44H/1815H/0H/"])
  116 
  117 --
  118 -- Derivation Index
  119 --
  120 
  121 newtype DerivationIndex = DerivationIndex { getDerivationIndex :: Word32 }
  122     deriving stock   (Show, Eq)
  123     deriving newtype (Bounded, Ord)
  124 
  125 -- | Safely cast a 'DerivationIndex' to an 'Integer'.
  126 indexToInteger :: DerivationIndex -> Integer
  127 indexToInteger (DerivationIndex ix) = fromIntegral ix
  128 
  129 -- | Get the first 'DerivationIndex' considered /hardened/.
  130 firstHardened :: DerivationIndex
  131 firstHardened = DerivationIndex 0x80000000
  132 
  133 -- | Smart-constructor for a 'DerivationIndex'
  134 mkDerivationIndex :: Integer -> Either String DerivationIndex
  135 mkDerivationIndex ix
  136     | ix > fromIntegral (maxBound @Word32) =
  137         Left $ show ix <> " is too high to be a derivation index."
  138     | otherwise =
  139         pure $ DerivationIndex $ fromIntegral ix
  140 
  141 -- | Convert a string to a derivation index. String must be followed by a
  142 -- capital /H/ to mark hardened index. For example @0@ refers to the first soft
  143 -- index, whereas @0H@ refers to the first hardened index.
  144 derivationIndexFromString :: String -> Either String DerivationIndex
  145 derivationIndexFromString "" = Left "An empty string is not a derivation index!"
  146 derivationIndexFromString str
  147     | "H" `isSuffixOf` str = do
  148         parseHardenedIndex (init str)
  149     | otherwise = do
  150         parseSoftIndex str
  151   where
  152     parseHardenedIndex txt = do
  153         ix <- left (const msg) $ readEitherSafe txt
  154         mkDerivationIndex $ ix + indexToInteger firstHardened
  155       where
  156         msg = mconcat
  157             [ "Unable to parse hardened index. Hardened indexes are integer "
  158             , "values, between "
  159             , show (indexToInteger (minBound @DerivationIndex))
  160             , " and "
  161             , show (indexToInteger firstHardened)
  162             , " ending with a capital 'H'. For example: \"42H\","
  163             ]
  164 
  165     parseSoftIndex txt = do
  166         ix <- left (const msg) $ readEitherSafe txt
  167         guardSoftIndex ix
  168         mkDerivationIndex ix
  169       where
  170         guardSoftIndex ix
  171             | ix >= indexToInteger firstHardened =
  172                 Left $ mconcat
  173                     [ show ix
  174                     , " is too high to be a soft derivation index. "
  175                     , "Did you mean \""
  176                     , show (ix - indexToInteger firstHardened)
  177                     , "H\"?"
  178                     ]
  179             | otherwise =
  180                 pure ()
  181 
  182         msg = mconcat
  183             [ "Unable to parse soft index. Soft indexes are integer "
  184             , "values, between "
  185             , show (indexToInteger (minBound @DerivationIndex))
  186             , " and "
  187             , show (indexToInteger firstHardened)
  188             , ". For example: \"14\"."
  189             ]
  190 
  191 -- | Convert a 'DerivationIndex' back to string.
  192 derivationIndexToString :: DerivationIndex -> String
  193 derivationIndexToString ix_@(DerivationIndex ix)
  194     | ix_ >= firstHardened = show ix' ++ "H"
  195     | otherwise            = show ix
  196   where
  197     ix' = fromIntegral ix - indexToInteger firstHardened
  198 
  199 --
  200 -- XPub / Pub / XPrv
  201 --
  202 
  203 xpubReader :: [HumanReadablePart] -> String -> Either String XPub
  204 xpubReader allowedPrefixes str = do
  205     (_hrp, bytes) <- bech32Reader allowedPrefixes str
  206     case xpubFromBytes bytes of
  207         Just xpub -> pure xpub
  208         Nothing   -> Left
  209             "Failed to convert bytes into a valid extended public key."
  210 
  211 pubReader :: [HumanReadablePart] -> String -> Either String Pub
  212 pubReader allowedPrefixes str = do
  213     (_hrp, bytes) <- bech32Reader allowedPrefixes str
  214     case pubFromBytes bytes of
  215         Just pub -> pure pub
  216         Nothing   -> Left
  217             "Failed to convert bytes into a valid non-extended public key."
  218 
  219 xpubOpt :: [HumanReadablePart] -> String -> String -> Parser XPub
  220 xpubOpt allowedPrefixes name helpDoc =
  221     option (eitherReader (xpubReader allowedPrefixes)) $ mempty
  222         <> long name
  223         <> metavar "XPUB"
  224         <> help helpDoc
  225 
  226 xpubArg :: [HumanReadablePart] -> String -> Parser XPub
  227 xpubArg allowedPrefixes helpDoc =
  228     argument (eitherReader (xpubReader allowedPrefixes)) $ mempty
  229         <> metavar "XPUB"
  230         <> help helpDoc
  231 
  232 keyhashReader :: (KeyRole, [HumanReadablePart]) -> String -> Either String KeyHash
  233 keyhashReader (keyrole, allowedPrefixes) str = do
  234     (_hrp, bytes) <- bech32Reader allowedPrefixes str
  235     case keyHashFromBytes (keyrole, bytes) of
  236         Just keyhash -> pure keyhash
  237         Nothing   -> Left
  238             "Failed to convert bytes into a valid public key hash."
  239 
  240 --
  241 -- Internal
  242 --
  243 
  244 bech32Reader
  245     :: [HumanReadablePart]
  246     -> String
  247     -> Either String (HumanReadablePart, ByteString)
  248 bech32Reader allowedPrefixes str = do
  249     (hrp, bytes) <- fromBech32 markCharsRedAtIndices (toBytes str)
  250     unless (hrp `elem` allowedPrefixes) $ Left
  251         $ "Invalid human-readable prefix. Prefix ought to be one of: "
  252         <> show (showHrp <$> allowedPrefixes)
  253     pure (hrp, bytes)
  254   where
  255     showHrp :: HumanReadablePart -> String
  256     showHrp = T.unpack . humanReadablePartToText
  257 
  258     toBytes :: String -> ByteString
  259     toBytes = T.encodeUtf8 . T.pack