cardano-addresses-4.0.2: lib/Cardano/Address/KeyHash.hs

{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-}

{-# OPTIONS_HADDOCK prune #-}

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

module Cardano.Address.KeyHash
    (
    -- * Types
      KeyHash (..)
    , KeyRole (..)
    , GovernanceType (..)

    -- * Conversions
    , keyHashFromBytes
    , keyHashFromText
    , keyHashToText

    -- * Errors
    , ErrKeyHashFromText
    , prettyErrKeyHashFromText
    ) where

import Prelude

import Cardano.Address.Derivation
    ( credentialHashSize, hashCredential )
import Codec.Binary.Encoding
    ( AbstractEncoding (..), encode, fromBase16 )
import Control.DeepSeq
    ( NFData )
import Data.Aeson
    ( ToJSON (..), Value (..) )
import Data.Bifunctor
    ( first )
import Data.ByteString
    ( ByteString )
import Data.Either.Combinators
    ( maybeToRight )
import Data.Text
    ( Text )
import GHC.Generics
    ( Generic )

import qualified Cardano.Codec.Bech32.Prefixes as CIP5
import qualified Codec.Binary.Bech32 as Bech32
import qualified Data.ByteString as BS
import qualified Data.Text.Encoding as T

-- | Determines if one asks for deprecated HRP prefixes, __*_vkh__ and __*_script__
-- in accordance to [CIP-0105](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0105) (on demand when flag 'cip-0105' is used) or uses default format
-- specified in [CIP-0129](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0129) (where additional byte is prepended to 28-byte hash).
data GovernanceType = NoGovernance | CIP0129 | CIP0105
    deriving (Eq, Show)

-- | Determines the role a given key plays.
--
-- The role basically can be mapped into derivation path
-- which was used to derive it from the parent. Also it has a dedicated user facing HRP
-- when presented in bech32 format - see 'keyHashToText' for more details.
--
-- Take notice that purpose/role (except 'Policy') are as defined below in derivation path:
--
-- @
-- m / purpose' / coin_type' / account_ix' / role / index
-- @
--
-- 'Policy' has a dedicated derivation path as follows:
--
-- @
-- m / purpose' / coin_type' / policy_ix'
-- @
--
--
-- +------------------+------------+--------+------------------------------------------------------------------------------+
-- |    KeyRole       |   purpose  |  role  |                                  CIP                                         |
-- +==================+============+========+==============================================================================+
-- | PaymentShared    |   1854H    |   0,1  | [CIP-1854](https://github.com/cardano-foundation/CIPs/tree/master/CIP-1854)  |
-- +------------------+------------+--------+------------------------------------------------------------------------------+
-- | DelegationShared |   1854H    |   2    | [CIP-1854](https://github.com/cardano-foundation/CIPs/tree/master/CIP-1854)  |
-- +------------------+------------+--------+------------------------------------------------------------------------------+
-- | Payment          |   1852H    |   0,1  | [CIP-1852](https://github.com/cardano-foundation/CIPs/tree/master/CIP-1852)  |
-- +------------------+------------+--------+------------------------------------------------------------------------------+
-- | Delegation       |   1852H    |   2    | [CIP-0011](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0011)  |
-- +------------------+------------+--------+------------------------------------------------------------------------------+
-- | Representative   |   1852H    |   3    | [CIP-0105](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0105)  |
-- +------------------+------------+--------+------------------------------------------------------------------------------+
-- | CommitteeCold    |   1852H    |   4    | [CIP-0105](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0105)  |
-- +------------------+------------+--------+------------------------------------------------------------------------------+
-- | CommitteeHot     |   1852H    |   5    | [CIP-0105](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0105)  |
-- +------------------+------------+--------+------------------------------------------------------------------------------+
-- | Policy           |   1855H    |   -    | [CIP-1855](https://github.com/cardano-foundation/CIPs/tree/master/CIP-1855)  |
-- +------------------+------------+--------+------------------------------------------------------------------------------+
--
data KeyRole =
      PaymentShared
    | DelegationShared
    | Payment
    | Delegation
    | Policy
    | Representative
    | CommitteeCold
    | CommitteeHot
    | Unknown
    deriving (Generic, Show, Ord, Eq)
instance NFData KeyRole

-- | A 'KeyHash' type represents verification key hash that participate in building
-- multi-signature script. The hash is expected to have size of 28-byte.
--
-- @since 3.0.0
data KeyHash = KeyHash
    { role :: KeyRole
    , digest :: ByteString }
    deriving (Generic, Show, Ord, Eq)
instance NFData KeyHash

-- | Construct an 'KeyHash' from raw 'ByteString' (28 bytes).
--
-- @since 3.0.0
keyHashFromBytes :: (KeyRole, ByteString) -> Maybe KeyHash
keyHashFromBytes (cred, bytes)
    | BS.length bytes /= credentialHashSize = Nothing
    | otherwise = Just $ KeyHash cred bytes

-- | Encode a 'KeyHash' to bech32 'Text' or hex is key role unknown.
--  If one wants to include, valid in governance roles only, additional byte
--  as specified in CIP-0129, the function needs to be called with withByte=true.
--
-- @since 3.0.0
keyHashToText :: KeyHash -> GovernanceType -> Text
keyHashToText (KeyHash cred keyHash) govType = case cred of
    PaymentShared ->
        T.decodeUtf8 $ encode (EBech32 CIP5.addr_shared_vkh) keyHash
    DelegationShared ->
        T.decodeUtf8 $ encode (EBech32 CIP5.stake_shared_vkh) keyHash
    Payment ->
        T.decodeUtf8 $ encode (EBech32 CIP5.addr_vkh) keyHash
    Delegation ->
        T.decodeUtf8 $ encode (EBech32 CIP5.stake_vkh) keyHash
    Policy ->
        T.decodeUtf8 $ encode (EBech32 CIP5.policy_vkh) keyHash
    Representative -> case govType of
        CIP0105 ->
            T.decodeUtf8 $ encode (EBech32 CIP5.drep_vkh) keyHash
        _ ->
            T.decodeUtf8 $ encode (EBech32 CIP5.drep) $ keyHashAppendByteCIP0129 keyHash cred
    CommitteeCold -> case govType of
        CIP0105 ->
            T.decodeUtf8 $ encode (EBech32 CIP5.cc_cold_vkh) keyHash
        _ ->
            T.decodeUtf8 $ encode (EBech32 CIP5.cc_cold) $ keyHashAppendByteCIP0129 keyHash cred
    CommitteeHot -> case govType of
        CIP0105 ->
            T.decodeUtf8 $ encode (EBech32 CIP5.cc_hot_vkh) keyHash
        _ ->
            T.decodeUtf8 $ encode (EBech32 CIP5.cc_hot) $ keyHashAppendByteCIP0129 keyHash cred
    Unknown ->
        T.decodeUtf8 $ encode EBase16 keyHash

-- | In accordance to CIP-0129 (https://github.com/cardano-foundation/CIPs/tree/master/CIP-0129)
--   one byte is prepended to vkh only in governance context. The rules how to contruct it are summarized
--   below
--
--   drep       0010....
--   hot        0000....    key type
--   cold       0001....
--
--   keyhash    ....0010
--   This is on top of X_vkh, where X={drep, cc_hot, cc_hot}, which lacks the additional byte.
--   In `keyHashFromText` we additionally
--   support reading legacy X which also lacks the additional byte, and has the same payload as
--   as the corresponding X_vkh.
keyHashAppendByteCIP0129 :: ByteString -> KeyRole -> ByteString
keyHashAppendByteCIP0129 payload cred =
    maybe payload (`BS.cons` payload) bytePrefix
  where
    bytePrefix = case cred of
        Representative -> Just 0b00100010
        CommitteeCold -> Just 0b00010010
        CommitteeHot -> Just 0b00000010
        _ -> Nothing

-- | Construct a 'KeyHash' from 'Text'. It should be
-- Bech32 encoded text with one of following hrp:
--
-- - `addr_shared_vkh`
-- - `stake_shared_vkh`
-- - `addr_vkh`
-- - `stake_vkh`
-- - `policy_vkh`
-- - `drep`
-- - `cc_cold`
-- - `cc_hot`
-- - `drep_vkh`
-- - `cc_cold_vkh`
-- - `cc_hot_vkh`
-- - `addr_shared_vk`
-- - `stake_shared_vk`
-- - `addr_vk`
-- - `stake_vk`
-- - `policy_vk`
-- - `cc_cold_vk`
-- - `cc_hot_vk`
-- - `addr_shared_xvk`
-- - `stake_shared_xvk`
-- - `addr_xvk`
-- - `stake_xvk`
-- - `policy_xvk`
-- - `drep_xvk`
-- - `cc_cold_xvk`
-- - `cc_hot_xvk`
--
-- Raw keys will be hashed on the fly, whereas hash that are directly
-- provided will remain as such.
-- If if hex is encountered 'Unknown' policy key is assumed.
--
-- @since 3.1.0
keyHashFromText :: Text -> Either ErrKeyHashFromText KeyHash
keyHashFromText txt =
    case (fromBase16 $ T.encodeUtf8 txt) of
        Right bs ->
            if checkBSLength bs 28 then
                pure $ KeyHash Unknown bs
            else if checkBSLength bs 32 then
                pure $ KeyHash Unknown (hashCredential bs)
            else if checkBSLength bs 64 then
                pure $ KeyHash Unknown (hashCredential $ BS.take 32 bs)
            else
                Left (ErrKeyHashFromTextInvalidHex $ BS.length bs)
        Left _ -> do
            (hrp, dp) <- first (const ErrKeyHashFromTextInvalidString) $
                Bech32.decodeLenient txt

            maybeToRight ErrKeyHashFromTextWrongDataPart (Bech32.dataPartToBytes dp)
                >>= maybeToRight ErrKeyHashFromTextWrongHrp . convertBytes hrp
                >>= maybeToRight ErrKeyHashFromTextWrongPayload . keyHashFromBytes
 where
    convertBytes hrp bytes
        | hrp == CIP5.addr_shared_vkh && checkBSLength bytes 28 =
              Just (PaymentShared, bytes)
        | hrp == CIP5.stake_shared_vkh && checkBSLength bytes 28 =
              Just (DelegationShared, bytes)
        | hrp == CIP5.addr_vkh && checkBSLength bytes 28 =
              Just (Payment, bytes)
        | hrp == CIP5.stake_vkh && checkBSLength bytes 28 =
              Just (Delegation, bytes)
        | hrp == CIP5.policy_vkh && checkBSLength bytes 28 =
              Just (Policy, bytes)
        | hrp == CIP5.drep && checkBSLength bytes 29 =
              let (fstByte, payload) = first BS.head $ BS.splitAt 1 bytes
              --   drep          0010....
              --   keyhash       ....0010
              in if fstByte == 0b00100010 then
                  Just (Representative, payload)
                 else
                  Nothing
        | hrp == CIP5.drep && checkBSLength bytes 28 =
              Just (Representative, bytes)
        | hrp == CIP5.drep_vkh && checkBSLength bytes 28 =
              Just (Representative, bytes)
        | hrp == CIP5.cc_cold && checkBSLength bytes 29 =
              let (fstByte, payload) = first BS.head $ BS.splitAt 1 bytes
              --   cold          0001....
              --   keyhash       ....0010
              in if fstByte == 0b00010010 then
                  Just (CommitteeCold, payload)
                 else
                  Nothing
        | hrp == CIP5.cc_cold && checkBSLength bytes 28 =
              Just (CommitteeCold, bytes)
        | hrp == CIP5.cc_cold_vkh && checkBSLength bytes 28 =
              Just (CommitteeCold, bytes)
        | hrp == CIP5.cc_hot && checkBSLength bytes 29 =
              let (fstByte, payload) = first BS.head $ BS.splitAt 1 bytes
              --   hot           0000....
              --   keyhash       ....0010
              in if fstByte == 0b00000010 then
                  Just (CommitteeHot, payload)
                 else
                  Nothing
        | hrp == CIP5.cc_hot && checkBSLength bytes 28 =
              Just (CommitteeHot, bytes)
        | hrp == CIP5.cc_hot_vkh && checkBSLength bytes 28 =
              Just (CommitteeHot, bytes)
        | hrp == CIP5.addr_shared_vk && checkBSLength bytes 32 =
              Just (PaymentShared, hashCredential bytes)
        | hrp == CIP5.addr_vk && checkBSLength bytes 32 =
              Just (Payment, hashCredential bytes)
        | hrp == CIP5.addr_shared_xvk && checkBSLength bytes 64 =
              Just (PaymentShared, hashCredential $ BS.take 32 bytes)
        | hrp == CIP5.addr_xvk && checkBSLength bytes 64 =
              Just (Payment, hashCredential $ BS.take 32 bytes)
        | hrp == CIP5.stake_shared_vk && checkBSLength bytes 32 =
              Just (DelegationShared, hashCredential bytes)
        | hrp == CIP5.stake_vk && checkBSLength bytes 32 =
              Just (Delegation, hashCredential bytes)
        | hrp == CIP5.stake_shared_xvk && checkBSLength bytes 64 =
              Just (DelegationShared, hashCredential $ BS.take 32 bytes)
        | hrp == CIP5.stake_xvk && checkBSLength bytes 64 =
              Just (Delegation, hashCredential $ BS.take 32 bytes)
        | hrp == CIP5.policy_vk && checkBSLength bytes 32 =
              Just (Policy, hashCredential bytes)
        | hrp == CIP5.policy_xvk && checkBSLength bytes 64 =
              Just (Policy, hashCredential $ BS.take 32 bytes)
        | hrp == CIP5.drep_vk && checkBSLength bytes 32 =
              Just (Representative, hashCredential bytes)
        | hrp == CIP5.drep_xvk && checkBSLength bytes 64 =
              Just (Representative, hashCredential $ BS.take 32 bytes)
        | hrp == CIP5.cc_cold_vk && checkBSLength bytes 32 =
              Just (CommitteeCold, hashCredential bytes)
        | hrp == CIP5.cc_cold_xvk && checkBSLength bytes 64 =
              Just (CommitteeCold, hashCredential $ BS.take 32 bytes)
        | hrp == CIP5.cc_hot_vk && checkBSLength bytes 32 =
              Just (CommitteeHot, hashCredential bytes)
        | hrp == CIP5.cc_hot_xvk && checkBSLength bytes 64 =
              Just (CommitteeHot, hashCredential $ BS.take 32 bytes)
        | otherwise = Nothing
    checkBSLength :: ByteString -> Int -> Bool
    checkBSLength bytes expLength =
        BS.length bytes == expLength

-- | Possible errors when deserializing a key hash from text.
--
-- @since 3.0.0
data ErrKeyHashFromText
    = ErrKeyHashFromTextInvalidString
    | ErrKeyHashFromTextWrongPayload
    | ErrKeyHashFromTextWrongHrp
    | ErrKeyHashFromTextWrongDataPart
    | ErrKeyHashFromTextInvalidHex Int
    deriving (Show, Eq)

-- | Possible errors when deserializing a key hash from text.
--
-- @since 3.0.0
prettyErrKeyHashFromText :: ErrKeyHashFromText -> String
prettyErrKeyHashFromText = \case
    ErrKeyHashFromTextInvalidString ->
        "Invalid encoded string: must be either bech32 or hex-encoded."
    ErrKeyHashFromTextWrongPayload ->
        "Verification key hash must contain exactly 28 bytes."
    ErrKeyHashFromTextWrongHrp ->
        "Invalid human-readable prefix: must be 'X_vkh', 'X_vk', 'X_xvk' where X is 'addr_shared', 'stake_shared' or 'policy'."
    ErrKeyHashFromTextWrongDataPart ->
        "Verification key hash is Bech32-encoded but has an invalid data part."
    ErrKeyHashFromTextInvalidHex size->
        "Invalid hex-encoded string: must be either 28, 32 or 64 bytes, but has " <> show size <> " bytes."

instance ToJSON KeyHash where
    toJSON = String . flip keyHashToText CIP0129