Derivation.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}

{-# OPTIONS_HADDOCK hide #-}

-- |
-- Copyright: 2020 Input Output (Hong Kong) Ltd., 2021-2022 Input Output Global Inc. (IOG), 2023-2025 Intersect
-- License: Apache-2.0

module Options.Applicative.Derivation
    (
    -- * Derivation Path
    -- ** Type
      DerivationPath
    , castDerivationPath
    , derivationPathToString
    , derivationPathFromString
    -- ** Applicative Parser
    , derivationPathArg

    -- * Derivation Index
    , DerivationIndex
    , mkDerivationIndex
    , firstHardened
    , indexToInteger
    , derivationIndexToString
    , derivationIndexFromString

    -- * XPub / Pub / XPrv / KeyHash
    , xpubReader
    , xpubOpt
    , xpubArg
    , keyhashReader
    , pubReader

    -- * Internal
    , bech32Reader
    ) where

import Prelude

import Cardano.Address.Derivation
    ( DerivationType (..)
    , Index
    , Pub
    , XPub
    , pubFromBytes
    , wholeDomainIndex
    , xpubFromBytes
    )
import Cardano.Address.KeyHash
    ( KeyHash (..), KeyRole (..), keyHashFromBytes )
import Codec.Binary.Bech32
    ( HumanReadablePart, humanReadablePartToText )
import Codec.Binary.Encoding
    ( fromBech32 )
import Control.Arrow
    ( left )
import Control.Monad
    ( unless )
import Data.ByteString
    ( ByteString )
import Data.List
    ( intercalate, isSuffixOf )
import Data.Word
    ( Word32 )
import Options.Applicative
    ( Parser
    , argument
    , completer
    , eitherReader
    , help
    , listCompleter
    , long
    , metavar
    , option
    )
import Safe
    ( readEitherSafe )
import System.IO.Extra
    ( markCharsRedAtIndices )

import qualified Data.Text as T
import qualified Data.Text.Encoding as T


--
-- Derivation Path
--

-- | Represent a user-provided 'DerivationPath'.
newtype DerivationPath = DerivationPath [DerivationIndex]
    deriving (Show, Eq)

derivationPathFromString :: String -> Either String DerivationPath
derivationPathFromString str =
    DerivationPath
        <$> mapM (derivationIndexFromString . T.unpack) (T.splitOn "/" txt)
  where
    txt = T.pack str

derivationPathToString :: DerivationPath -> String
derivationPathToString (DerivationPath xs) =
    intercalate "/" $ map derivationIndexToString xs

castDerivationPath :: DerivationPath -> [Index 'WholeDomain depth]
castDerivationPath (DerivationPath xs) = map (wholeDomainIndex . getDerivationIndex) xs

derivationPathArg :: Parser DerivationPath
derivationPathArg = argument (eitherReader derivationPathFromString) $ mempty
    <> metavar "DERIVATION-PATH"
    <> help
        "Slash-separated derivation path. Hardened indexes are marked with a \
        \'H' (e.g. 1852H/1815H/0H/0)."
    <> completer (listCompleter ["1852H/1815H/0H/", "44H/1815H/0H/"])

--
-- Derivation Index
--

newtype DerivationIndex = DerivationIndex { getDerivationIndex :: Word32 }
    deriving stock   (Show, Eq)
    deriving newtype (Bounded, Ord)

-- | Safely cast a 'DerivationIndex' to an 'Integer'.
indexToInteger :: DerivationIndex -> Integer
indexToInteger (DerivationIndex ix) = fromIntegral ix

-- | Get the first 'DerivationIndex' considered /hardened/.
firstHardened :: DerivationIndex
firstHardened = DerivationIndex 0x80000000

-- | Smart-constructor for a 'DerivationIndex'
mkDerivationIndex :: Integer -> Either String DerivationIndex
mkDerivationIndex ix
    | ix > fromIntegral (maxBound @Word32) =
        Left $ show ix <> " is too high to be a derivation index."
    | otherwise =
        pure $ DerivationIndex $ fromIntegral ix

-- | Convert a string to a derivation index. String must be followed by a
-- capital /H/ to mark hardened index. For example @0@ refers to the first soft
-- index, whereas @0H@ refers to the first hardened index.
derivationIndexFromString :: String -> Either String DerivationIndex
derivationIndexFromString "" = Left "An empty string is not a derivation index!"
derivationIndexFromString str
    | "H" `isSuffixOf` str = do
        parseHardenedIndex (init str)
    | otherwise = do
        parseSoftIndex str
  where
    parseHardenedIndex txt = do
        ix <- left (const msg) $ readEitherSafe txt
        mkDerivationIndex $ ix + indexToInteger firstHardened
      where
        msg = mconcat
            [ "Unable to parse hardened index. Hardened indexes are integer "
            , "values, between "
            , show (indexToInteger (minBound @DerivationIndex))
            , " and "
            , show (indexToInteger firstHardened)
            , " ending with a capital 'H'. For example: \"42H\","
            ]

    parseSoftIndex txt = do
        ix <- left (const msg) $ readEitherSafe txt
        guardSoftIndex ix
        mkDerivationIndex ix
      where
        guardSoftIndex ix
            | ix >= indexToInteger firstHardened =
                Left $ mconcat
                    [ show ix
                    , " is too high to be a soft derivation index. "
                    , "Did you mean \""
                    , show (ix - indexToInteger firstHardened)
                    , "H\"?"
                    ]
            | otherwise =
                pure ()

        msg = mconcat
            [ "Unable to parse soft index. Soft indexes are integer "
            , "values, between "
            , show (indexToInteger (minBound @DerivationIndex))
            , " and "
            , show (indexToInteger firstHardened)
            , ". For example: \"14\"."
            ]

-- | Convert a 'DerivationIndex' back to string.
derivationIndexToString :: DerivationIndex -> String
derivationIndexToString ix_@(DerivationIndex ix)
    | ix_ >= firstHardened = show ix' ++ "H"
    | otherwise            = show ix
  where
    ix' = fromIntegral ix - indexToInteger firstHardened

--
-- XPub / Pub / XPrv
--

xpubReader :: [HumanReadablePart] -> String -> Either String XPub
xpubReader allowedPrefixes str = do
    (_hrp, bytes) <- bech32Reader allowedPrefixes str
    case xpubFromBytes bytes of
        Just xpub -> pure xpub
        Nothing   -> Left
            "Failed to convert bytes into a valid extended public key."

pubReader :: [HumanReadablePart] -> String -> Either String Pub
pubReader allowedPrefixes str = do
    (_hrp, bytes) <- bech32Reader allowedPrefixes str
    case pubFromBytes bytes of
        Just pub -> pure pub
        Nothing   -> Left
            "Failed to convert bytes into a valid non-extended public key."

xpubOpt :: [HumanReadablePart] -> String -> String -> Parser XPub
xpubOpt allowedPrefixes name helpDoc =
    option (eitherReader (xpubReader allowedPrefixes)) $ mempty
        <> long name
        <> metavar "XPUB"
        <> help helpDoc

xpubArg :: [HumanReadablePart] -> String -> Parser XPub
xpubArg allowedPrefixes helpDoc =
    argument (eitherReader (xpubReader allowedPrefixes)) $ mempty
        <> metavar "XPUB"
        <> help helpDoc

keyhashReader :: (KeyRole, [HumanReadablePart]) -> String -> Either String KeyHash
keyhashReader (keyrole, allowedPrefixes) str = do
    (_hrp, bytes) <- bech32Reader allowedPrefixes str
    case keyHashFromBytes (keyrole, bytes) of
        Just keyhash -> pure keyhash
        Nothing   -> Left
            "Failed to convert bytes into a valid public key hash."

--
-- Internal
--

bech32Reader
    :: [HumanReadablePart]
    -> String
    -> Either String (HumanReadablePart, ByteString)
bech32Reader allowedPrefixes str = do
    (hrp, bytes) <- fromBech32 markCharsRedAtIndices (toBytes str)
    unless (hrp `elem` allowedPrefixes) $ Left
        $ "Invalid human-readable prefix. Prefix ought to be one of: "
        <> show (showHrp <$> allowedPrefixes)
    pure (hrp, bytes)
  where
    showHrp :: HumanReadablePart -> String
    showHrp = T.unpack . humanReadablePartToText

    toBytes :: String -> ByteString
    toBytes = T.encodeUtf8 . T.pack