{-# 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.Plutus.Data (Data (..), getPlutusData)
import Cardano.Ledger.Plutus.ExUnits (ExUnits (..))
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
  = TxOutFromInput !TxIn
  | TxOutFromOutput !TxIx
  deriving (TxOutSource -> TxOutSource -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TxOutSource -> TxOutSource -> Bool
$c/= :: TxOutSource -> TxOutSource -> Bool
== :: TxOutSource -> TxOutSource -> Bool
$c== :: TxOutSource -> TxOutSource -> Bool
Eq, Int -> TxOutSource -> ShowS
[TxOutSource] -> ShowS
TxOutSource -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TxOutSource] -> ShowS
$cshowList :: [TxOutSource] -> ShowS
show :: TxOutSource -> String
$cshow :: TxOutSource -> String
showsPrec :: Int -> TxOutSource -> ShowS
$cshowsPrec :: Int -> TxOutSource -> ShowS
Show, forall x. Rep TxOutSource x -> TxOutSource
forall x. TxOutSource -> Rep TxOutSource x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TxOutSource x -> TxOutSource
$cfrom :: forall x. TxOutSource -> Rep TxOutSource x
Generic, Context -> TxOutSource -> IO (Maybe ThunkInfo)
Proxy TxOutSource -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy TxOutSource -> String
$cshowTypeOf :: Proxy TxOutSource -> String
wNoThunks :: Context -> TxOutSource -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> TxOutSource -> IO (Maybe ThunkInfo)
noThunks :: Context -> TxOutSource -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> TxOutSource -> IO (Maybe ThunkInfo)
NoThunks)

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

instance EncCBOR TxOutSource where
  encCBOR :: TxOutSource -> Encoding
encCBOR = \case
    TxOutFromInput TxIn
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 TxIn -> TxOutSource
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
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 TxIx -> TxOutSource
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 DecCBOR TxOutSource where
  decCBOR :: forall s. Decoder s TxOutSource
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" Word -> Decode 'Open TxOutSource
dec)
    where
      dec :: Word -> Decode 'Open TxOutSource
dec Word
0 = forall t. t -> Decode 'Open t
SumD TxIn -> TxOutSource
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 TxIx -> TxOutSource
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 where
  toJSON :: TxOutSource -> Value
toJSON = Text -> Value
String forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOutSource -> Text
txOutSourceToText

txOutSourceToText :: TxOutSource -> Text
txOutSourceToText :: TxOutSource -> Text
txOutSourceToText = \case
  TxOutFromInput TxIn
txIn -> Text
"Input: " forall a. Semigroup a => a -> a -> a
<> TxIn -> Text
txInToText TxIn
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 -> PV1.DatumHash
transDataHash :: DataHash -> DatumHash
transDataHash DataHash
safe = BuiltinByteString -> DatumHash
PV1.DatumHash (forall i. SafeHash i -> BuiltinByteString
transSafeHash DataHash
safe)

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

transSafeHash :: SafeHash i -> PV1.BuiltinByteString
transSafeHash :: forall i. SafeHash 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 i. SafeHash i -> Hash HASH i
extractHash

transScriptHash :: ScriptHash -> PV1.ScriptHash
transScriptHash :: ScriptHash -> ScriptHash
transScriptHash (ScriptHash Hash ADDRHASH 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 EraIndependentScript
h))

transStakeReference :: StakeReference -> Maybe PV1.StakingCredential
transStakeReference :: StakeReference -> Maybe StakingCredential
transStakeReference (StakeRefBase StakeCredential
cred) = forall a. a -> Maybe a
Just (Credential -> StakingCredential
PV1.StakingHash (forall (kr :: KeyRole). Credential kr -> Credential
transCred StakeCredential
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
StakeRefNull = forall a. Maybe a
Nothing

transCred :: Credential kr -> PV1.Credential
transCred :: forall (kr :: KeyRole). Credential kr -> Credential
transCred (KeyHashObj (KeyHash Hash ADDRHASH (VerKeyDSIGN DSIGN)
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 (VerKeyDSIGN DSIGN)
kh)))
transCred (ScriptHashObj (ScriptHash Hash ADDRHASH 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 EraIndependentScript
sh)))

-- | Translate an address. `Cardano.Ledger.BaseTypes.NetworkId` is discarded and Byron
-- Addresses will result in Nothing.
transAddr :: Addr -> Maybe PV1.Address
transAddr :: Addr -> Maybe Address
transAddr = \case
  AddrBootstrap {} -> forall a. Maybe a
Nothing
  Addr Network
_networkId PaymentCredential
paymentCred StakeReference
stakeReference ->
    forall a. a -> Maybe a
Just (Credential -> Maybe StakingCredential -> Address
PV1.Address (forall (kr :: KeyRole). Credential kr -> Credential
transCred PaymentCredential
paymentCred) (StakeReference -> Maybe StakingCredential
transStakeReference StakeReference
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 -> PV1.Credential
transRewardAccount :: RewardAccount -> Credential
transRewardAccount (RewardAccount Network
_networkId StakeCredential
cred) = forall (kr :: KeyRole). Credential kr -> Credential
transCred StakeCredential
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 -> PV1.TxId
transTxId :: TxId -> TxId
transTxId (TxId SafeHash EraIndependentTxBody
safe) = BuiltinByteString -> TxId
PV1.TxId (forall i. SafeHash i -> BuiltinByteString
transSafeHash SafeHash EraIndependentTxBody
safe)

transTxIn :: TxIn -> PV1.TxOutRef
transTxIn :: TxIn -> TxOutRef
transTxIn (TxIn TxId
txid TxIx
txIx) = TxId -> Integer -> TxOutRef
PV1.TxOutRef (TxId -> TxId
transTxId TxId
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, Data era) -> (PV1.DatumHash, PV1.Datum)
transDataPair :: forall era. (DataHash, Data era) -> (DatumHash, Datum)
transDataPair (DataHash
x, Data era
y) = (DataHash -> DatumHash
transDataHash DataHash
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