{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | User-friendly pretty-printing for textual user interfaces (TUI)
module Bcc.CLI.Run.Friendly (friendlyTxBodyBS) where

import           Bcc.Prelude

import           Data.Aeson (Value (..), object, toJSON, (.=))
import qualified Data.Aeson as Aeson
import           Data.Yaml (array)
import           Data.Yaml.Pretty (defConfig, encodePretty, setConfCompare)

import           Bcc.Api
import           Bcc.Api.Cole (Entropic (..))
import           Bcc.Api.Sophie (Address (SophieAddress), StakeAddress (..))
import           Bcc.Ledger.Crypto (Crypto)
import qualified Sophie.Spec.Ledger.API as Sophie

import           Bcc.CLI.Helpers (textShow)

friendlyTxBodyBS :: BccEra era -> TxBody era -> ByteString
friendlyTxBodyBS :: BccEra era -> TxBody era -> ByteString
friendlyTxBodyBS BccEra era
era =
  Config -> Value -> ByteString
forall a. ToJSON a => Config -> a -> ByteString
encodePretty ((Text -> Text -> Ordering) -> Config -> Config
setConfCompare Text -> Text -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Config
defConfig) (Value -> ByteString)
-> (TxBody era -> Value) -> TxBody era -> ByteString
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. BccEra era -> TxBody era -> Value
forall era. BccEra era -> TxBody era -> Value
friendlyTxBody BccEra era
era

friendlyTxBody :: BccEra era -> TxBody era -> Aeson.Value
friendlyTxBody :: BccEra era -> TxBody era -> Value
friendlyTxBody
  BccEra era
era
  (TxBody
    TxBodyContent
      { TxAuxScripts era
txAuxScripts :: forall build era. TxBodyContent build era -> TxAuxScripts era
txAuxScripts :: TxAuxScripts era
txAuxScripts
      , TxCertificates ViewTx era
txCertificates :: forall build era.
TxBodyContent build era -> TxCertificates build era
txCertificates :: TxCertificates ViewTx era
txCertificates
      , TxFee era
txFee :: forall build era. TxBodyContent build era -> TxFee era
txFee :: TxFee era
txFee
      , TxIns ViewTx era
txIns :: forall build era. TxBodyContent build era -> TxIns build era
txIns :: TxIns ViewTx era
txIns
      , TxMetadataInEra era
txMetadata :: forall build era. TxBodyContent build era -> TxMetadataInEra era
txMetadata :: TxMetadataInEra era
txMetadata
      , TxMintValue ViewTx era
txMintValue :: forall build era. TxBodyContent build era -> TxMintValue build era
txMintValue :: TxMintValue ViewTx era
txMintValue
      , [TxOut era]
txOuts :: forall build era. TxBodyContent build era -> [TxOut era]
txOuts :: [TxOut era]
txOuts
      , TxUpdateProposal era
txUpdateProposal :: forall build era. TxBodyContent build era -> TxUpdateProposal era
txUpdateProposal :: TxUpdateProposal era
txUpdateProposal
      , (TxValidityLowerBound era, TxValidityUpperBound era)
txValidityRange :: forall build era.
TxBodyContent build era
-> (TxValidityLowerBound era, TxValidityUpperBound era)
txValidityRange :: (TxValidityLowerBound era, TxValidityUpperBound era)
txValidityRange
      , TxWithdrawals ViewTx era
txWithdrawals :: forall build era.
TxBodyContent build era -> TxWithdrawals build era
txWithdrawals :: TxWithdrawals ViewTx era
txWithdrawals
      }) =
  [Pair] -> Value
object
    [ Text
"auxiliary scripts" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= TxAuxScripts era -> Value
forall era. TxAuxScripts era -> Value
friendlyAuxScripts TxAuxScripts era
txAuxScripts
    , Text
"certificates" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= TxCertificates ViewTx era -> Value
forall era. TxCertificates ViewTx era -> Value
friendlyCertificates TxCertificates ViewTx era
txCertificates
    , Text
"era" Text -> BccEra era -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= BccEra era
era
    , Text
"fee" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= TxFee era -> Value
forall era. TxFee era -> Value
friendlyFee TxFee era
txFee
    , Text
"inputs" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= TxIns ViewTx era -> Value
forall build. [(TxIn, build)] -> Value
friendlyInputs TxIns ViewTx era
txIns
    , Text
"metadata" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= TxMetadataInEra era -> Value
forall era. TxMetadataInEra era -> Value
friendlyMetadata TxMetadataInEra era
txMetadata
    , Text
"mint" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= TxMintValue ViewTx era -> Value
forall era. TxMintValue ViewTx era -> Value
friendlyMintValue TxMintValue ViewTx era
txMintValue
    , Text
"outputs" Text -> [Value] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (TxOut era -> Value) -> [TxOut era] -> [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map TxOut era -> Value
forall era. TxOut era -> Value
friendlyTxOut [TxOut era]
txOuts
    , Text
"update proposal" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= TxUpdateProposal era -> Value
forall era. TxUpdateProposal era -> Value
friendlyUpdateProposal TxUpdateProposal era
txUpdateProposal
    , Text
"validity range" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= BccEra era
-> (TxValidityLowerBound era, TxValidityUpperBound era) -> Value
forall era.
BccEra era
-> (TxValidityLowerBound era, TxValidityUpperBound era) -> Value
friendlyValidityRange BccEra era
era (TxValidityLowerBound era, TxValidityUpperBound era)
txValidityRange
    , Text
"withdrawals" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= TxWithdrawals ViewTx era -> Value
forall era. TxWithdrawals ViewTx era -> Value
friendlyWithdrawals TxWithdrawals ViewTx era
txWithdrawals
    ]

-- | Special case of validity range:
-- in Sophie, upper bound is TTL, and no lower bound
pattern SophieTtl
  :: SlotNo -> (TxValidityLowerBound era, TxValidityUpperBound era)
pattern $mSophieTtl :: forall r era.
(TxValidityLowerBound era, TxValidityUpperBound era)
-> (SlotNo -> r) -> (Void# -> r) -> r
SophieTtl ttl <-
  ( TxValidityNoLowerBound
  , TxValidityUpperBound ValidityUpperBoundInSophieEra ttl
  )

friendlyValidityRange
  :: BccEra era
  -> (TxValidityLowerBound era, TxValidityUpperBound era)
  -> Aeson.Value
friendlyValidityRange :: BccEra era
-> (TxValidityLowerBound era, TxValidityUpperBound era) -> Value
friendlyValidityRange BccEra era
era = \case
  SophieTtl SlotNo
ttl -> [Pair] -> Value
object [Text
"time to live" Text -> SlotNo -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SlotNo
ttl]
  (TxValidityLowerBound era
lowerBound, TxValidityUpperBound era
upperBound)
    | Bool
isLowerBoundSupported Bool -> Bool -> Bool
|| Bool
isUpperBoundSupported ->
        [Pair] -> Value
object
          [ Text
"lower bound" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.=
                case TxValidityLowerBound era
lowerBound of
                  TxValidityLowerBound era
TxValidityNoLowerBound -> Value
Null
                  TxValidityLowerBound ValidityLowerBoundSupportedInEra era
_ SlotNo
s -> SlotNo -> Value
forall a. ToJSON a => a -> Value
toJSON SlotNo
s
          , Text
"upper bound" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.=
              case TxValidityUpperBound era
upperBound of
                TxValidityNoUpperBound ValidityNoUpperBoundSupportedInEra era
_ -> Value
Null
                TxValidityUpperBound ValidityUpperBoundSupportedInEra era
_ SlotNo
s -> SlotNo -> Value
forall a. ToJSON a => a -> Value
toJSON SlotNo
s
          ]
    | Bool
otherwise -> Value
Null
  where
    isLowerBoundSupported :: Bool
isLowerBoundSupported = Maybe (ValidityLowerBoundSupportedInEra era) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (ValidityLowerBoundSupportedInEra era) -> Bool)
-> Maybe (ValidityLowerBoundSupportedInEra era) -> Bool
forall a b. (a -> b) -> a -> b
$ BccEra era -> Maybe (ValidityLowerBoundSupportedInEra era)
forall era.
BccEra era -> Maybe (ValidityLowerBoundSupportedInEra era)
validityLowerBoundSupportedInEra BccEra era
era
    isUpperBoundSupported :: Bool
isUpperBoundSupported = Maybe (ValidityUpperBoundSupportedInEra era) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (ValidityUpperBoundSupportedInEra era) -> Bool)
-> Maybe (ValidityUpperBoundSupportedInEra era) -> Bool
forall a b. (a -> b) -> a -> b
$ BccEra era -> Maybe (ValidityUpperBoundSupportedInEra era)
forall era.
BccEra era -> Maybe (ValidityUpperBoundSupportedInEra era)
validityUpperBoundSupportedInEra BccEra era
era

friendlyWithdrawals :: TxWithdrawals ViewTx era -> Aeson.Value
friendlyWithdrawals :: TxWithdrawals ViewTx era -> Value
friendlyWithdrawals TxWithdrawals ViewTx era
TxWithdrawalsNone = Value
Null
friendlyWithdrawals (TxWithdrawals WithdrawalsSupportedInEra era
_ [(StakeAddress, Entropic,
  BuildTxWith ViewTx (Witness WitCtxStake era))]
withdrawals) =
  [Value] -> Value
array
    [ [Pair] -> Value
object
        [ Text
"address" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= StakeAddress -> Text
forall addr. SerialiseAddress addr => addr -> Text
serialiseAddress StakeAddress
addr
        , Text
"network" Text -> Network -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Network
net
        , Text
"credential" Text -> StakeCredential StandardCrypto -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= StakeCredential StandardCrypto
cred
        , Text
"amount" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Entropic -> Value
friendlyEntropic Entropic
amount
        ]
    | (addr :: StakeAddress
addr@(StakeAddress Network
net StakeCredential StandardCrypto
cred), Entropic
amount, BuildTxWith ViewTx (Witness WitCtxStake era)
_) <- [(StakeAddress, Entropic,
  BuildTxWith ViewTx (Witness WitCtxStake era))]
withdrawals
    ]

friendlyTxOut :: TxOut era -> Aeson.Value
friendlyTxOut :: TxOut era -> Value
friendlyTxOut (TxOut AddressInEra era
addr TxOutValue era
amount TxOutDatumHash era
mdatum) =
  case AddressInEra era
addr of
    AddressInEra AddressTypeInEra addrtype era
ColeAddressInAnyEra Address addrtype
_ ->
      [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ (Text
"address era" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text -> Value
String Text
"Cole") Pair -> [Pair] -> [Pair]
forall a. a -> [a] -> [a]
: [Pair]
common
    AddressInEra (SophieAddressInEra SophieBasedEra era
_) (SophieAddress Network
net PaymentCredential StandardCrypto
cred StakeReference StandardCrypto
stake) ->
      [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$
        [ Text
"address era" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text -> Value
String Text
"Sophie"
        , Text
"network" Text -> Network -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Network
net
        , Text
"payment credential" Text -> PaymentCredential StandardCrypto -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= PaymentCredential StandardCrypto
cred
        , Text
"stake reference" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= StakeReference StandardCrypto -> Value
forall crypto. Crypto crypto => StakeReference crypto -> Value
friendlyStakeReference StakeReference StandardCrypto
stake
        ]
        [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [Text
"datum" Text -> Hash ScriptData -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Hash ScriptData
datum | TxOutDatumHash ScriptDataSupportedInEra era
_ Hash ScriptData
datum <- [TxOutDatumHash era
mdatum]]
        [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [Pair]
common
  where
    common :: [(Text, Aeson.Value)]
    common :: [Pair]
common =
      [ Text
"address" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= AddressInEra era -> Text
forall era. AddressInEra era -> Text
serialiseAddressForTxOut AddressInEra era
addr
      , Text
"amount" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= TxOutValue era -> Value
forall era. TxOutValue era -> Value
friendlyTxOutValue TxOutValue era
amount
      ]

friendlyStakeReference :: Crypto crypto => Sophie.StakeReference crypto -> Aeson.Value
friendlyStakeReference :: StakeReference crypto -> Value
friendlyStakeReference = \case
  Sophie.StakeRefBase StakeCredential crypto
cred -> StakeCredential crypto -> Value
forall a. ToJSON a => a -> Value
toJSON StakeCredential crypto
cred
  StakeReference crypto
Sophie.StakeRefNull -> Value
Null
  Sophie.StakeRefPtr Ptr
ptr -> Ptr -> Value
forall a. ToJSON a => a -> Value
toJSON Ptr
ptr

friendlyUpdateProposal :: TxUpdateProposal era -> Aeson.Value
friendlyUpdateProposal :: TxUpdateProposal era -> Value
friendlyUpdateProposal = \case
  TxUpdateProposal era
TxUpdateProposalNone -> Value
Null
  TxUpdateProposal UpdateProposalSupportedInEra era
_ UpdateProposal
p -> Text -> Value
String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ UpdateProposal -> Text
forall a. Show a => a -> Text
textShow UpdateProposal
p

friendlyCertificates :: TxCertificates ViewTx era -> Aeson.Value
friendlyCertificates :: TxCertificates ViewTx era -> Value
friendlyCertificates = \case
  TxCertificates ViewTx era
TxCertificatesNone -> Value
Null
  TxCertificates CertificatesSupportedInEra era
_ [Certificate]
cs BuildTxWith ViewTx (Map StakeCredential (Witness WitCtxStake era))
_ -> [Text] -> Value
forall a. ToJSON a => a -> Value
toJSON ([Text] -> Value) -> [Text] -> Value
forall a b. (a -> b) -> a -> b
$ (Certificate -> Text) -> [Certificate] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Certificate -> Text
forall a. Show a => a -> Text
textShow [Certificate]
cs

friendlyFee :: TxFee era -> Aeson.Value
friendlyFee :: TxFee era -> Value
friendlyFee = \case
  TxFeeImplicit TxFeesImplicitInEra era
_ -> Value
"implicit"
  TxFeeExplicit TxFeesExplicitInEra era
_ Entropic
fee -> Entropic -> Value
friendlyEntropic Entropic
fee

friendlyEntropic :: Entropic -> Aeson.Value
friendlyEntropic :: Entropic -> Value
friendlyEntropic (Entropic Integer
value) = Text -> Value
String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ Integer -> Text
forall a. Show a => a -> Text
textShow Integer
value Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" Entropic"

friendlyMintValue :: TxMintValue ViewTx era -> Aeson.Value
friendlyMintValue :: TxMintValue ViewTx era -> Value
friendlyMintValue = \case
  TxMintValue ViewTx era
TxMintNone -> Value
Null
  TxMintValue MultiAssetSupportedInEra era
_ Value
v BuildTxWith ViewTx (Map PolicyId (ScriptWitness WitCtxMint era))
_ ->
    [Pair] -> Value
object
      [ AssetId -> Text
friendlyAssetId AssetId
assetId Text -> Quantity -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Quantity
quantity
      | (AssetId
assetId, Quantity
quantity) <- Value -> [(AssetId, Quantity)]
valueToList Value
v
      ]

friendlyAssetId :: AssetId -> Text
friendlyAssetId :: AssetId -> Text
friendlyAssetId = \case
  AssetId
BccAssetId -> Text
"BCC"
  AssetId PolicyId
policyId (AssetName ByteString
assetName) ->
    ByteString -> Text
decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ PolicyId -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytesHex PolicyId
policyId ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
suffix
    where
      suffix :: ByteString
suffix =
        case ByteString
assetName of
          ByteString
"" -> ByteString
""
          ByteString
_ -> ByteString
"." ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
assetName

friendlyTxOutValue :: TxOutValue era -> Aeson.Value
friendlyTxOutValue :: TxOutValue era -> Value
friendlyTxOutValue = \case
  TxOutBccOnly OnlyBccSupportedInEra era
_ Entropic
entropic -> Entropic -> Value
friendlyEntropic Entropic
entropic
  TxOutValue MultiAssetSupportedInEra era
_ Value
multiasset -> Value -> Value
forall a. ToJSON a => a -> Value
toJSON Value
multiasset

friendlyMetadata :: TxMetadataInEra era -> Aeson.Value
friendlyMetadata :: TxMetadataInEra era -> Value
friendlyMetadata = \case
  TxMetadataInEra era
TxMetadataNone -> Value
Null
  TxMetadataInEra TxMetadataSupportedInEra era
_ (TxMetadata Map Word64 TxMetadataValue
m) -> Map Word64 Value -> Value
forall a. ToJSON a => a -> Value
toJSON (Map Word64 Value -> Value) -> Map Word64 Value -> Value
forall a b. (a -> b) -> a -> b
$ TxMetadataValue -> Value
friendlyMetadataValue (TxMetadataValue -> Value)
-> Map Word64 TxMetadataValue -> Map Word64 Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Word64 TxMetadataValue
m

friendlyMetadataValue :: TxMetadataValue -> Aeson.Value
friendlyMetadataValue :: TxMetadataValue -> Value
friendlyMetadataValue = \case
  TxMetaNumber Integer
int -> Integer -> Value
forall a. ToJSON a => a -> Value
toJSON Integer
int
  TxMetaBytes ByteString
bytes -> Text -> Value
String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
forall a. Show a => a -> Text
textShow ByteString
bytes
  TxMetaList [TxMetadataValue]
lst -> [Value] -> Value
array ([Value] -> Value) -> [Value] -> Value
forall a b. (a -> b) -> a -> b
$ (TxMetadataValue -> Value) -> [TxMetadataValue] -> [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map TxMetadataValue -> Value
friendlyMetadataValue [TxMetadataValue]
lst
  TxMetaMap [(TxMetadataValue, TxMetadataValue)]
m ->
    [Value] -> Value
array
      [[Value] -> Value
array [TxMetadataValue -> Value
friendlyMetadataValue TxMetadataValue
k, TxMetadataValue -> Value
friendlyMetadataValue TxMetadataValue
v] | (TxMetadataValue
k, TxMetadataValue
v) <- [(TxMetadataValue, TxMetadataValue)]
m]
  TxMetaText Text
text -> Text -> Value
forall a. ToJSON a => a -> Value
toJSON Text
text

friendlyAuxScripts :: TxAuxScripts era -> Aeson.Value
friendlyAuxScripts :: TxAuxScripts era -> Value
friendlyAuxScripts = \case
  TxAuxScripts era
TxAuxScriptsNone -> Value
Null
  TxAuxScripts AuxScriptsSupportedInEra era
_ [ScriptInEra era]
scripts -> Text -> Value
String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ [ScriptInEra era] -> Text
forall a. Show a => a -> Text
textShow [ScriptInEra era]
scripts

friendlyInputs :: [(TxIn, build)] -> Aeson.Value
friendlyInputs :: [(TxIn, build)] -> Value
friendlyInputs = [TxIn] -> Value
forall a. ToJSON a => a -> Value
toJSON ([TxIn] -> Value)
-> ([(TxIn, build)] -> [TxIn]) -> [(TxIn, build)] -> Value
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ((TxIn, build) -> TxIn) -> [(TxIn, build)] -> [TxIn]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (TxIn, build) -> TxIn
forall a b. (a, b) -> a
fst