{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}

module Cardano.Ledger.Plutus.TxInfo (
  TxOutSource (..),
  txOutSourceToText,
  transAddr,
  transRewardAccount,
  transDataHash,
  transKeyHash,
  transSafeHash,
  transScriptHash,
  transTxId,
  transStakeReference,
  transCred,
  slotToPOSIXTime,
  transTxIn,
  transCoinToValue,
  transCoinToLovelace,
  transDataPair,
  transExUnits,
  exBudgetToExUnits,
  transBoundedRational,
  transEpochNo,
  transEpochInterval,
  transDatum,
)
where

import Cardano.Crypto.Hash.Class (hashToBytes)
import Cardano.Ledger.Address (Addr (..), RewardAccount (..))
import Cardano.Ledger.BaseTypes (
  BoundedRational (unboundRational),
  EpochInterval (..),
  EpochNo (..),
  TxIx,
  certIxToInt,
  txIxToInt,
 )
import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..))
import Cardano.Ledger.Binary.Coders (
  Decode (..),
  Encode (..),
  decode,
  encode,
  (!>),
  (<!),
 )
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential (..), Ptr (..), StakeReference (..))
import Cardano.Ledger.Crypto (Crypto)
import Cardano.Ledger.Keys (KeyHash (..))
import Cardano.Ledger.Plutus.Data (Data (..), getPlutusData)
import Cardano.Ledger.Plutus.ExUnits (ExUnits (..))
import Cardano.Ledger.SafeHash (SafeHash, extractHash)
import Cardano.Ledger.TxIn (TxId (..), TxIn (..), txInToText)
import Cardano.Slotting.EpochInfo (EpochInfo, epochInfoSlotToUTCTime)
import Cardano.Slotting.Slot (SlotNo (..))
import Cardano.Slotting.Time (SystemStart)
import Control.DeepSeq (NFData (..), rwhnf)
import Data.Aeson (ToJSON (..), Value (String))
import Data.Text as T (Text, pack)
import Data.Time.Clock (nominalDiffTimeToSeconds)
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks)
import Numeric.Natural (Natural)
import PlutusLedgerApi.V1 (SatInt, fromSatInt)
import qualified PlutusLedgerApi.V1 as PV1
import qualified PlutusLedgerApi.V3 as PV3

-- =========================================================
-- Translate Hashes, Credentials, Certificates etc.

-- | A transaction output can be translated because it is a newly created output,
-- or because it is the output which is connected to a transaction input being spent.
data TxOutSource c
  = TxOutFromInput !(TxIn c)
  | TxOutFromOutput !TxIx
  deriving (TxOutSource c -> TxOutSource c -> Bool
forall c. TxOutSource c -> TxOutSource c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TxOutSource c -> TxOutSource c -> Bool
$c/= :: forall c. TxOutSource c -> TxOutSource c -> Bool
== :: TxOutSource c -> TxOutSource c -> Bool
$c== :: forall c. TxOutSource c -> TxOutSource c -> Bool
Eq, Int -> TxOutSource c -> ShowS
forall c. Int -> TxOutSource c -> ShowS
forall c. [TxOutSource c] -> ShowS
forall c. TxOutSource c -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TxOutSource c] -> ShowS
$cshowList :: forall c. [TxOutSource c] -> ShowS
show :: TxOutSource c -> String
$cshow :: forall c. TxOutSource c -> String
showsPrec :: Int -> TxOutSource c -> ShowS
$cshowsPrec :: forall c. Int -> TxOutSource c -> ShowS
Show, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x. Rep (TxOutSource c) x -> TxOutSource c
forall c x. TxOutSource c -> Rep (TxOutSource c) x
$cto :: forall c x. Rep (TxOutSource c) x -> TxOutSource c
$cfrom :: forall c x. TxOutSource c -> Rep (TxOutSource c) x
Generic, forall c. Context -> TxOutSource c -> IO (Maybe ThunkInfo)
forall c. Proxy (TxOutSource c) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy (TxOutSource c) -> String
$cshowTypeOf :: forall c. Proxy (TxOutSource c) -> String
wNoThunks :: Context -> TxOutSource c -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall c. Context -> TxOutSource c -> IO (Maybe ThunkInfo)
noThunks :: Context -> TxOutSource c -> IO (Maybe ThunkInfo)
$cnoThunks :: forall c. Context -> TxOutSource c -> IO (Maybe ThunkInfo)
NoThunks)

instance NFData (TxOutSource era) where
  rnf :: TxOutSource era -> ()
rnf = forall a. a -> ()
rwhnf

instance Crypto c => EncCBOR (TxOutSource c) where
  encCBOR :: TxOutSource c -> Encoding
encCBOR = \case
    TxOutFromInput TxIn c
txIn -> forall (w :: Wrapped) t. Encode w t -> Encoding
encode forall a b. (a -> b) -> a -> b
$ forall t. t -> Word -> Encode 'Open t
Sum forall c. TxIn c -> TxOutSource c
TxOutFromInput Word
0 forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To TxIn c
txIn
    TxOutFromOutput TxIx
txIx -> forall (w :: Wrapped) t. Encode w t -> Encoding
encode forall a b. (a -> b) -> a -> b
$ forall t. t -> Word -> Encode 'Open t
Sum forall c. TxIx -> TxOutSource c
TxOutFromOutput Word
1 forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To TxIx
txIx

instance Crypto c => DecCBOR (TxOutSource c) where
  decCBOR :: forall s. Decoder s (TxOutSource c)
decCBOR = forall (w :: Wrapped) t s. Decode w t -> Decoder s t
decode (forall t.
Text -> (Word -> Decode 'Open t) -> Decode ('Closed 'Dense) t
Summands Text
"TxOutSource" forall {c}. Crypto c => Word -> Decode 'Open (TxOutSource c)
dec)
    where
      dec :: Word -> Decode 'Open (TxOutSource c)
dec Word
0 = forall t. t -> Decode 'Open t
SumD forall c. TxIn c -> TxOutSource c
TxOutFromInput forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
      dec Word
1 = forall t. t -> Decode 'Open t
SumD forall c. TxIx -> TxOutSource c
TxOutFromOutput forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
      dec Word
n = forall (w :: Wrapped) t. Word -> Decode w t
Invalid Word
n

instance ToJSON (TxOutSource c) where
  toJSON :: TxOutSource c -> Value
toJSON = Text -> Value
String forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. TxOutSource c -> Text
txOutSourceToText

txOutSourceToText :: TxOutSource c -> Text
txOutSourceToText :: forall c. TxOutSource c -> Text
txOutSourceToText = \case
  TxOutFromInput TxIn c
txIn -> Text
"Input: " forall a. Semigroup a => a -> a -> a
<> forall c. TxIn c -> Text
txInToText TxIn c
txIn
  TxOutFromOutput TxIx
txIx -> Text
"Output: " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show TxIx
txIx)

transBoundedRational :: BoundedRational r => r -> PV3.Rational
transBoundedRational :: forall r. BoundedRational r => r -> Rational
transBoundedRational = Rational -> Rational
PV3.fromGHC forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. BoundedRational r => r -> Rational
unboundRational

transDataHash :: DataHash c -> PV1.DatumHash
transDataHash :: forall c. DataHash c -> DatumHash
transDataHash DataHash c
safe = BuiltinByteString -> DatumHash
PV1.DatumHash (forall c i. SafeHash c i -> BuiltinByteString
transSafeHash DataHash c
safe)

transKeyHash :: KeyHash d c -> PV1.PubKeyHash
transKeyHash :: forall (d :: KeyRole) c. KeyHash d c -> PubKeyHash
transKeyHash (KeyHash Hash (ADDRHASH c) (VerKeyDSIGN (DSIGN c))
h) = BuiltinByteString -> PubKeyHash
PV1.PubKeyHash (forall a. HasToBuiltin a => a -> ToBuiltin a
PV1.toBuiltin (forall h a. Hash h a -> ByteString
hashToBytes Hash (ADDRHASH c) (VerKeyDSIGN (DSIGN c))
h))

transSafeHash :: SafeHash c i -> PV1.BuiltinByteString
transSafeHash :: forall c i. SafeHash c i -> BuiltinByteString
transSafeHash = forall a. HasToBuiltin a => a -> ToBuiltin a
PV1.toBuiltin forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall h a. Hash h a -> ByteString
hashToBytes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c i. SafeHash c i -> Hash (HASH c) i
extractHash

transScriptHash :: ScriptHash c -> PV1.ScriptHash
transScriptHash :: forall c. ScriptHash c -> ScriptHash
transScriptHash (ScriptHash Hash (ADDRHASH c) EraIndependentScript
h) = BuiltinByteString -> ScriptHash
PV1.ScriptHash (forall a. HasToBuiltin a => a -> ToBuiltin a
PV1.toBuiltin (forall h a. Hash h a -> ByteString
hashToBytes Hash (ADDRHASH c) EraIndependentScript
h))

transStakeReference :: StakeReference c -> Maybe PV1.StakingCredential
transStakeReference :: forall c. StakeReference c -> Maybe StakingCredential
transStakeReference (StakeRefBase StakeCredential c
cred) = forall a. a -> Maybe a
Just (Credential -> StakingCredential
PV1.StakingHash (forall (kr :: KeyRole) c. Credential kr c -> Credential
transCred StakeCredential c
cred))
transStakeReference (StakeRefPtr (Ptr (SlotNo Word64
slot) TxIx
txIx CertIx
certIx)) =
  let !txIxInteger :: Integer
txIxInteger = forall a. Integral a => a -> Integer
toInteger (TxIx -> Int
txIxToInt TxIx
txIx)
      !certIxInteger :: Integer
certIxInteger = forall a. Integral a => a -> Integer
toInteger (CertIx -> Int
certIxToInt CertIx
certIx)
   in forall a. a -> Maybe a
Just (Integer -> Integer -> Integer -> StakingCredential
PV1.StakingPtr (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
slot) Integer
txIxInteger Integer
certIxInteger)
transStakeReference StakeReference c
StakeRefNull = forall a. Maybe a
Nothing

transCred :: Credential kr c -> PV1.Credential
transCred :: forall (kr :: KeyRole) c. Credential kr c -> Credential
transCred (KeyHashObj (KeyHash Hash (ADDRHASH c) (VerKeyDSIGN (DSIGN c))
kh)) =
  PubKeyHash -> Credential
PV1.PubKeyCredential (BuiltinByteString -> PubKeyHash
PV1.PubKeyHash (forall a. HasToBuiltin a => a -> ToBuiltin a
PV1.toBuiltin (forall h a. Hash h a -> ByteString
hashToBytes Hash (ADDRHASH c) (VerKeyDSIGN (DSIGN c))
kh)))
transCred (ScriptHashObj (ScriptHash Hash (ADDRHASH c) EraIndependentScript
sh)) =
  ScriptHash -> Credential
PV1.ScriptCredential (BuiltinByteString -> ScriptHash
PV1.ScriptHash (forall a. HasToBuiltin a => a -> ToBuiltin a
PV1.toBuiltin (forall h a. Hash h a -> ByteString
hashToBytes Hash (ADDRHASH c) EraIndependentScript
sh)))

-- | Translate an address. `Cardano.Ledger.BaseTypes.NetworkId` is discarded and Byron
-- Addresses will result in Nothing.
transAddr :: Addr c -> Maybe PV1.Address
transAddr :: forall c. Addr c -> Maybe Address
transAddr = \case
  AddrBootstrap {} -> forall a. Maybe a
Nothing
  Addr Network
_networkId PaymentCredential c
paymentCred StakeReference c
stakeReference ->
    forall a. a -> Maybe a
Just (Credential -> Maybe StakingCredential -> Address
PV1.Address (forall (kr :: KeyRole) c. Credential kr c -> Credential
transCred PaymentCredential c
paymentCred) (forall c. StakeReference c -> Maybe StakingCredential
transStakeReference StakeReference c
stakeReference))

-- | Translate reward account by discarding `NetowrkId` and only translating the staking credential.
--
-- /Note/ - This function is the right one to use starting with PlutusV3, prior to that an
-- extra `PV1.StakingHash` wrapper is needed.
transRewardAccount :: RewardAccount c -> PV1.Credential
transRewardAccount :: forall c. RewardAccount c -> Credential
transRewardAccount (RewardAccount Network
_networkId Credential 'Staking c
cred) = forall (kr :: KeyRole) c. Credential kr c -> Credential
transCred Credential 'Staking c
cred

slotToPOSIXTime ::
  EpochInfo (Either Text) ->
  SystemStart ->
  SlotNo ->
  Either Text PV1.POSIXTime
slotToPOSIXTime :: EpochInfo (Either Text)
-> SystemStart -> SlotNo -> Either Text POSIXTime
slotToPOSIXTime EpochInfo (Either Text)
ei SystemStart
sysS SlotNo
s = do
  Integer -> POSIXTime
PV1.POSIXTime forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (RealFrac a, Integral b) => a -> b
truncate forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
* Pico
1000)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTime -> Pico
nominalDiffTimeToSeconds forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> NominalDiffTime
utcTimeToPOSIXSeconds
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(HasCallStack, Monad m) =>
EpochInfo m -> SystemStart -> SlotNo -> m UTCTime
epochInfoSlotToUTCTime EpochInfo (Either Text)
ei SystemStart
sysS SlotNo
s

-- ========================================
-- translate TxIn and TxOut

transTxId :: TxId c -> PV1.TxId
transTxId :: forall c. TxId c -> TxId
transTxId (TxId SafeHash c EraIndependentTxBody
safe) = BuiltinByteString -> TxId
PV1.TxId (forall c i. SafeHash c i -> BuiltinByteString
transSafeHash SafeHash c EraIndependentTxBody
safe)

transTxIn :: TxIn c -> PV1.TxOutRef
transTxIn :: forall c. TxIn c -> TxOutRef
transTxIn (TxIn TxId c
txid TxIx
txIx) = TxId -> Integer -> TxOutRef
PV1.TxOutRef (forall c. TxId c -> TxId
transTxId TxId c
txid) (forall a. Integral a => a -> Integer
toInteger (TxIx -> Int
txIxToInt TxIx
txIx))

transCoinToValue :: Coin -> PV1.Value
transCoinToValue :: Coin -> Value
transCoinToValue (Coin Integer
c) = CurrencySymbol -> TokenName -> Integer -> Value
PV1.singleton CurrencySymbol
PV1.adaSymbol TokenName
PV1.adaToken Integer
c

transDataPair :: (DataHash c, Data era) -> (PV1.DatumHash, PV1.Datum)
transDataPair :: forall c era. (DataHash c, Data era) -> (DatumHash, Datum)
transDataPair (DataHash c
x, Data era
y) = (forall c. DataHash c -> DatumHash
transDataHash DataHash c
x, BuiltinData -> Datum
PV1.Datum (Data -> BuiltinData
PV1.dataToBuiltinData (forall era. Data era -> Data
getPlutusData Data era
y)))

transExUnits :: ExUnits -> PV1.ExBudget
transExUnits :: ExUnits -> ExBudget
transExUnits (ExUnits Natural
mem Natural
steps) =
  ExCPU -> ExMemory -> ExBudget
PV1.ExBudget (SatInt -> ExCPU
PV1.ExCPU (forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
steps)) (SatInt -> ExMemory
PV1.ExMemory (forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
mem))

exBudgetToExUnits :: PV1.ExBudget -> Maybe ExUnits
exBudgetToExUnits :: ExBudget -> Maybe ExUnits
exBudgetToExUnits (PV1.ExBudget (PV1.ExCPU SatInt
steps) (PV1.ExMemory SatInt
memory)) =
  Natural -> Natural -> ExUnits
ExUnits
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SatInt -> Maybe Natural
safeFromSatInt SatInt
memory
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SatInt -> Maybe Natural
safeFromSatInt SatInt
steps
  where
    safeFromSatInt :: SatInt -> Maybe Natural
    safeFromSatInt :: SatInt -> Maybe Natural
safeFromSatInt SatInt
i
      | SatInt
i forall a. Ord a => a -> a -> Bool
>= SatInt
0 = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => Integer -> a
fromInteger forall a b. (a -> b) -> a -> b
$ forall a. Num a => SatInt -> a
fromSatInt SatInt
i
      | Bool
otherwise = forall a. Maybe a
Nothing

transCoinToLovelace :: Coin -> PV1.Lovelace
transCoinToLovelace :: Coin -> Lovelace
transCoinToLovelace (Coin Integer
c) = Integer -> Lovelace
PV1.Lovelace Integer
c

transEpochNo :: EpochNo -> Integer
transEpochNo :: EpochNo -> Integer
transEpochNo = forall a. Integral a => a -> Integer
toInteger forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpochNo -> Word64
unEpochNo

transEpochInterval :: EpochInterval -> Integer
transEpochInterval :: EpochInterval -> Integer
transEpochInterval = forall a. Integral a => a -> Integer
toInteger forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpochInterval -> Word32
unEpochInterval

transDatum :: Data era -> PV3.Datum
transDatum :: forall era. Data era -> Datum
transDatum = BuiltinData -> Datum
PV1.Datum forall b c a. (b -> c) -> (a -> b) -> a -> c
. Data -> BuiltinData
PV1.dataToBuiltinData forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Data era -> Data
getPlutusData