{-# 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.Internal.Utils
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
  (HumanReadablePart
prefix, DataPart
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 :: Text
actualPrefix = HumanReadablePart -> Text
Bech32.humanReadablePartToText HumanReadablePart
prefix
      permittedPrefixes :: [Text]
permittedPrefixes = AsType a -> [Text]
forall a. Cip129 a => AsType a -> [Text]
cip129Bech32PrefixesPermitted (forall t. HasTypeProxy t => AsType t
asType @a)
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text
actualPrefix Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
permittedPrefixes)
    Maybe () -> Bech32DecodeError -> Either Bech32DecodeError ()
forall a e. Maybe a -> e -> Either e a
?! Text -> Set Text -> Bech32DecodeError
Bech32UnexpectedPrefix Text
actualPrefix ([Item (Set Text)] -> Set Text
forall l. IsList l => [Item l] -> l
fromList [Item (Set Text)]
[Text]
permittedPrefixes)

  ByteString
payload <-
    DataPart -> Maybe ByteString
Bech32.dataPartToBytes DataPart
dataPart
      Maybe ByteString
-> Bech32DecodeError -> Either Bech32DecodeError ByteString
forall a e. Maybe a -> e -> Either e a
?! Text -> Bech32DecodeError
Bech32DataPartToBytesError (DataPart -> Text
Bech32.dataPartToText DataPart
dataPart)

  (ByteString
header, ByteString
credential) <-
    case ByteString -> Maybe (Char, ByteString)
C8.uncons ByteString
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

  a
value <- case AsType a -> ByteString -> Either SerialiseAsRawBytesError a
forall a.
SerialiseAsRawBytes a =>
AsType a -> ByteString -> Either SerialiseAsRawBytesError a
deserialiseFromRawBytes AsType a
forall t. HasTypeProxy t => AsType t
asType ByteString
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 :: ByteString
expectedHeader = a -> ByteString
forall a. Cip129 a => a -> ByteString
cip129HeaderHexByte a
value

  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ByteString
header ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
expectedHeader)
    Maybe () -> Bech32DecodeError -> Either Bech32DecodeError ()
forall a e. Maybe a -> e -> Either e a
?! Text -> Text -> Bech32DecodeError
Bech32UnexpectedHeader (ByteString -> Text
toBase16Text ByteString
expectedHeader) (ByteString -> Text
toBase16Text ByteString
header)

  let expectedPrefix :: Text
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)
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text
actualPrefix Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
expectedPrefix)
    Maybe () -> Bech32DecodeError -> Either Bech32DecodeError ()
forall a e. Maybe a -> e -> Either e a
?! Text -> Text -> Bech32DecodeError
Bech32WrongPrefix Text
actualPrefix Text
expectedPrefix

  a -> Either Bech32DecodeError a
forall a. a -> Either Bech32DecodeError a
forall (m :: * -> *) a. Monad m => a -> m a
return a
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"]
  (HumanReadablePart
prefix, DataPart
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 :: Text
actualPrefix = HumanReadablePart -> Text
Bech32.humanReadablePartToText HumanReadablePart
prefix
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text
actualPrefix Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
permittedPrefixes)
    Maybe () -> Bech32DecodeError -> Either Bech32DecodeError ()
forall a e. Maybe a -> e -> Either e a
?! Text -> Set Text -> Bech32DecodeError
Bech32UnexpectedPrefix Text
actualPrefix ([Item (Set Text)] -> Set Text
forall l. IsList l => [Item l] -> l
fromList [Item (Set Text)]
[Text]
permittedPrefixes)

  ByteString
payload <-
    DataPart -> Maybe ByteString
Bech32.dataPartToBytes DataPart
dataPart
      Maybe ByteString
-> Bech32DecodeError -> Either Bech32DecodeError ByteString
forall a e. Maybe a -> e -> Either e a
?! Text -> Bech32DecodeError
Bech32DataPartToBytesError (DataPart -> Text
Bech32.dataPartToText DataPart
dataPart)

  case AsType GovActionId
-> ByteString -> Either SerialiseAsRawBytesError GovActionId
forall a.
SerialiseAsRawBytes a =>
AsType a -> ByteString -> Either SerialiseAsRawBytesError a
deserialiseFromRawBytes AsType GovActionId
AsGovActionId ByteString
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