{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module Cardano.Api.Serialise.Cip129
  ( Cip129 (..)
  , deserialiseFromBech32Cip129
  , serialiseToBech32Cip129
  , serialiseGovActionIdToBech32Cip129
  , deserialiseGovActionIdFromBech32Cip129
  , AsType (AsColdCommitteeCredential, AsDrepCredential, AsHotCommitteeCredential)
  )
where

import Cardano.Api.Governance.Internal.Action.ProposalProcedure
import Cardano.Api.HasTypeProxy
import Cardano.Api.Internal.Orphans (AsType (..))
import Cardano.Api.Monad.Error
import Cardano.Api.Serialise.Bech32
import Cardano.Api.Serialise.Raw
import Cardano.Api.Tx.Internal.TxIn

import Cardano.Ledger.Conway.Governance qualified as Gov
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.Credential qualified as L
import Cardano.Ledger.Keys qualified as L

import Codec.Binary.Bech32 qualified as Bech32
import Control.Monad (guard)
import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.ByteString.Base16 qualified as Base16
import Data.ByteString.Char8 qualified as C8
import Data.Text (Text)
import Data.Text.Encoding qualified as Text
import GHC.Exts (IsList (..))

-- | Cip-129 is a typeclass that captures the serialisation requirements of https://cips.cardano.org/cip/CIP-0129
-- which pertain to governance credentials and governance action ids.
class (SerialiseAsRawBytes a, HasTypeProxy a) => Cip129 a where
  -- | The human readable part of the Bech32 encoding for the credential.
  cip129Bech32PrefixFor :: AsType a -> Bech32.HumanReadablePart

  -- | The header byte that identifies the credential type according to Cip-129.
  cip129HeaderHexByte :: a -> ByteString

  -- | Permitted bech32 prefixes according to Cip-129.
  cip129Bech32PrefixesPermitted :: AsType a -> [Text]
  default cip129Bech32PrefixesPermitted :: AsType a -> [Text]
  cip129Bech32PrefixesPermitted = Text -> [Text]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> [Text]) -> (AsType a -> Text) -> AsType a -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HumanReadablePart -> Text
Bech32.humanReadablePartToText (HumanReadablePart -> Text)
-> (AsType a -> HumanReadablePart) -> AsType a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AsType a -> HumanReadablePart
forall a. Cip129 a => AsType a -> HumanReadablePart
cip129Bech32PrefixFor

instance Cip129 (Credential L.ColdCommitteeRole) where
  cip129Bech32PrefixFor :: AsType (Credential 'ColdCommitteeRole) -> HumanReadablePart
cip129Bech32PrefixFor AsType (Credential 'ColdCommitteeRole)
_ = HasCallStack => Text -> HumanReadablePart
Text -> HumanReadablePart
unsafeHumanReadablePartFromText Text
"cc_cold"
  cip129Bech32PrefixesPermitted :: AsType (Credential 'ColdCommitteeRole) -> [Text]
cip129Bech32PrefixesPermitted AsType (Credential 'ColdCommitteeRole)
R:AsTypeCredential3
AsColdCommitteeCredential = [Text
"cc_cold"]

  cip129HeaderHexByte :: Credential 'ColdCommitteeRole -> ByteString
cip129HeaderHexByte =
    Word8 -> ByteString
BS.singleton (Word8 -> ByteString)
-> (Credential 'ColdCommitteeRole -> Word8)
-> Credential 'ColdCommitteeRole
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      L.KeyHashObj{} -> Word8
0x12 -- 0001 0010
      L.ScriptHashObj{} -> Word8
0x13 -- 0001 0011

instance Cip129 (Credential L.HotCommitteeRole) where
  cip129Bech32PrefixFor :: AsType (Credential 'HotCommitteeRole) -> HumanReadablePart
cip129Bech32PrefixFor AsType (Credential 'HotCommitteeRole)
_ = HasCallStack => Text -> HumanReadablePart
Text -> HumanReadablePart
unsafeHumanReadablePartFromText Text
"cc_hot"
  cip129Bech32PrefixesPermitted :: AsType (Credential 'HotCommitteeRole) -> [Text]
cip129Bech32PrefixesPermitted AsType (Credential 'HotCommitteeRole)
R:AsTypeCredential1
AsHotCommitteeCredential = [Text
"cc_hot"]
  cip129HeaderHexByte :: Credential 'HotCommitteeRole -> ByteString
cip129HeaderHexByte =
    Word8 -> ByteString
BS.singleton (Word8 -> ByteString)
-> (Credential 'HotCommitteeRole -> Word8)
-> Credential 'HotCommitteeRole
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      L.KeyHashObj{} -> Word8
0x02 -- 0000 0010
      L.ScriptHashObj{} -> Word8
0x03 -- 0000 0011

instance Cip129 (Credential L.DRepRole) where
  cip129Bech32PrefixFor :: AsType (Credential 'DRepRole) -> HumanReadablePart
cip129Bech32PrefixFor AsType (Credential 'DRepRole)
_ = HasCallStack => Text -> HumanReadablePart
Text -> HumanReadablePart
unsafeHumanReadablePartFromText Text
"drep"
  cip129Bech32PrefixesPermitted :: AsType (Credential 'DRepRole) -> [Text]
cip129Bech32PrefixesPermitted AsType (Credential 'DRepRole)
R:AsTypeCredential
AsDrepCredential = [Text
"drep"]
  cip129HeaderHexByte :: Credential 'DRepRole -> ByteString
cip129HeaderHexByte =
    Word8 -> ByteString
BS.singleton (Word8 -> ByteString)
-> (Credential 'DRepRole -> Word8)
-> Credential 'DRepRole
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      L.KeyHashObj{} -> Word8
0x22 -- 0010 0010
      L.ScriptHashObj{} -> Word8
0x23 -- 0010 0011

-- | Serialize a accoding to the serialisation requirements of https://cips.cardano.org/cip/CIP-0129
-- which currently pertain to governance credentials. Governance action ids are dealt separately with
-- via 'serialiseGovActionIdToBech32Cip129'.
serialiseToBech32Cip129 :: forall a. Cip129 a => a -> Text
serialiseToBech32Cip129 :: forall a. Cip129 a => a -> Text
serialiseToBech32Cip129 a
a =
  HumanReadablePart -> DataPart -> Text
Bech32.encodeLenient
    HumanReadablePart
humanReadablePart
    (ByteString -> DataPart
Bech32.dataPartFromBytes (a -> ByteString
forall a. Cip129 a => a -> ByteString
cip129HeaderHexByte a
a ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> a -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytes a
a))
 where
  humanReadablePart :: HumanReadablePart
humanReadablePart = AsType a -> HumanReadablePart
forall a. Cip129 a => AsType a -> HumanReadablePart
cip129Bech32PrefixFor (Proxy a -> AsType a
forall t. HasTypeProxy t => Proxy t -> AsType t
proxyToAsType (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a))

deserialiseFromBech32Cip129
  :: forall a
   . Cip129 a
  => Text
  -> Either Bech32DecodeError a
deserialiseFromBech32Cip129 :: forall a. Cip129 a => Text -> Either Bech32DecodeError a
deserialiseFromBech32Cip129 Text
bech32Str = do
  (prefix, dataPart) <-
    Text -> Either DecodingError (HumanReadablePart, DataPart)
Bech32.decodeLenient Text
bech32Str
      Either DecodingError (HumanReadablePart, DataPart)
-> (DecodingError -> Bech32DecodeError)
-> Either Bech32DecodeError (HumanReadablePart, DataPart)
forall e a e'. Either e a -> (e -> e') -> Either e' a
?!& DecodingError -> Bech32DecodeError
Bech32DecodingError

  let actualPrefix = HumanReadablePart -> Text
Bech32.humanReadablePartToText HumanReadablePart
prefix
      permittedPrefixes = AsType a -> [Text]
forall a. Cip129 a => AsType a -> [Text]
cip129Bech32PrefixesPermitted (forall t. HasTypeProxy t => AsType t
asType @a)
  guard (actualPrefix `elem` permittedPrefixes)
    ?! Bech32UnexpectedPrefix actualPrefix (fromList permittedPrefixes)

  payload <-
    Bech32.dataPartToBytes dataPart
      ?! Bech32DataPartToBytesError (Bech32.dataPartToText dataPart)

  (header, credential) <-
    case C8.uncons payload of
      Just (Char
header, ByteString
credential) -> (ByteString, ByteString)
-> Either Bech32DecodeError (ByteString, ByteString)
forall a. a -> Either Bech32DecodeError a
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> ByteString
C8.singleton Char
header, ByteString
credential)
      Maybe (Char, ByteString)
Nothing -> Bech32DecodeError
-> Either Bech32DecodeError (ByteString, ByteString)
forall a b. a -> Either a b
Left (Bech32DecodeError
 -> Either Bech32DecodeError (ByteString, ByteString))
-> Bech32DecodeError
-> Either Bech32DecodeError (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Bech32DecodeError
Bech32DeserialiseFromBytesError ByteString
payload

  value <- case deserialiseFromRawBytes asType credential of
    Right a
a -> a -> Either Bech32DecodeError a
forall a b. b -> Either a b
Right a
a
    Left SerialiseAsRawBytesError
_ -> Bech32DecodeError -> Either Bech32DecodeError a
forall a b. a -> Either a b
Left (Bech32DecodeError -> Either Bech32DecodeError a)
-> Bech32DecodeError -> Either Bech32DecodeError a
forall a b. (a -> b) -> a -> b
$ ByteString -> Bech32DecodeError
Bech32DeserialiseFromBytesError ByteString
payload

  let expectedHeader = a -> ByteString
forall a. Cip129 a => a -> ByteString
cip129HeaderHexByte a
value

  guard (header == expectedHeader)
    ?! Bech32UnexpectedHeader (toBase16Text expectedHeader) (toBase16Text header)

  let expectedPrefix = HumanReadablePart -> Text
Bech32.humanReadablePartToText (HumanReadablePart -> Text) -> HumanReadablePart -> Text
forall a b. (a -> b) -> a -> b
$ AsType a -> HumanReadablePart
forall a. Cip129 a => AsType a -> HumanReadablePart
cip129Bech32PrefixFor (forall t. HasTypeProxy t => AsType t
asType @a)
  guard (actualPrefix == expectedPrefix)
    ?! Bech32WrongPrefix actualPrefix expectedPrefix

  return value
 where
  toBase16Text :: ByteString -> Text
toBase16Text = ByteString -> Text
Text.decodeUtf8 (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base16.encode

-- | Governance Action ID
-- According to Cip129 there is no header byte for GovActionId.
-- Instead they append the txid and index to form the payload.
serialiseGovActionIdToBech32Cip129 :: Gov.GovActionId -> Text
serialiseGovActionIdToBech32Cip129 :: GovActionId -> Text
serialiseGovActionIdToBech32Cip129 (Gov.GovActionId TxId
txid GovActionIx
index) =
  let txidHex :: ByteString
txidHex = TxId -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytes (TxId -> ByteString) -> TxId -> ByteString
forall a b. (a -> b) -> a -> b
$ TxId -> TxId
fromShelleyTxId TxId
txid
      indexHex :: ByteString
indexHex = String -> ByteString
C8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Word16 -> String
forall a. Show a => a -> String
show (Word16 -> String) -> Word16 -> String
forall a b. (a -> b) -> a -> b
$ GovActionIx -> Word16
Gov.unGovActionIx GovActionIx
index
      payload :: ByteString
payload = ByteString
txidHex ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
indexHex
   in HumanReadablePart -> DataPart -> Text
Bech32.encodeLenient
        HumanReadablePart
humanReadablePart
        (ByteString -> DataPart
Bech32.dataPartFromBytes ByteString
payload)
 where
  humanReadablePart :: HumanReadablePart
humanReadablePart =
    let prefix :: Text
prefix = Text
"gov_action"
     in case Text -> Either HumanReadablePartError HumanReadablePart
Bech32.humanReadablePartFromText Text
prefix of
          Right HumanReadablePart
p -> HumanReadablePart
p
          Left HumanReadablePartError
err ->
            String -> HumanReadablePart
forall a. HasCallStack => String -> a
error (String -> HumanReadablePart) -> String -> HumanReadablePart
forall a b. (a -> b) -> a -> b
$
              String
"serialiseGovActionIdToBech32Cip129: invalid prefix "
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
prefix
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", "
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ HumanReadablePartError -> String
forall a. Show a => a -> String
show HumanReadablePartError
err

deserialiseGovActionIdFromBech32Cip129
  :: Text -> Either Bech32DecodeError Gov.GovActionId
deserialiseGovActionIdFromBech32Cip129 :: Text -> Either Bech32DecodeError GovActionId
deserialiseGovActionIdFromBech32Cip129 Text
bech32Str = do
  let permittedPrefixes :: [Text]
permittedPrefixes = [Text
"gov_action"]
  (prefix, dataPart) <-
    Text -> Either DecodingError (HumanReadablePart, DataPart)
Bech32.decodeLenient Text
bech32Str
      Either DecodingError (HumanReadablePart, DataPart)
-> (DecodingError -> Bech32DecodeError)
-> Either Bech32DecodeError (HumanReadablePart, DataPart)
forall e a e'. Either e a -> (e -> e') -> Either e' a
?!& DecodingError -> Bech32DecodeError
Bech32DecodingError
  let actualPrefix = HumanReadablePart -> Text
Bech32.humanReadablePartToText HumanReadablePart
prefix
  guard (actualPrefix `elem` permittedPrefixes)
    ?! Bech32UnexpectedPrefix actualPrefix (fromList permittedPrefixes)

  payload <-
    Bech32.dataPartToBytes dataPart
      ?! Bech32DataPartToBytesError (Bech32.dataPartToText dataPart)

  case deserialiseFromRawBytes AsGovActionId payload of
    Right GovActionId
a -> GovActionId -> Either Bech32DecodeError GovActionId
forall a b. b -> Either a b
Right GovActionId
a
    Left SerialiseAsRawBytesError
_ -> Bech32DecodeError -> Either Bech32DecodeError GovActionId
forall a b. a -> Either a b
Left (Bech32DecodeError -> Either Bech32DecodeError GovActionId)
-> Bech32DecodeError -> Either Bech32DecodeError GovActionId
forall a b. (a -> b) -> a -> b
$ ByteString -> Bech32DecodeError
Bech32DeserialiseFromBytesError ByteString
payload