module Hydra.Cardano.Api.UTxO where

import Hydra.Cardano.Api.Prelude
import Hydra.Cardano.Api.TxId (toLedgerTxId)
import Hydra.Cardano.Api.TxIn (fromLedgerTxIn, toLedgerTxIn, txIns')
import Hydra.Cardano.Api.TxOut (fromLedgerTxOut, toLedgerTxOut)

import Cardano.Api.UTxO qualified as UTxO
import Cardano.Ledger.Api (outputsTxBodyL)
import Cardano.Ledger.Babbage.TxBody qualified as Ledger
import Cardano.Ledger.BaseTypes qualified as Ledger
import Cardano.Ledger.Shelley.UTxO qualified as Ledger
import Cardano.Ledger.TxIn qualified as Ledger
import Control.Lens ((^.))
import Data.Foldable (toList)
import Data.Map qualified as Map
import Data.Maybe (mapMaybe)
import Data.String (IsString (..))
import Data.Text qualified as Text

-- | Get a human-readable pretty text representation of a UTxO.
renderUTxO :: IsString str => UTxO -> str
renderUTxO :: forall str. IsString str => UTxO -> str
renderUTxO =
  String -> str
forall a. IsString a => String -> a
fromString (String -> str) -> (UTxO -> String) -> UTxO -> str
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack (Text -> String) -> (UTxO -> Text) -> UTxO -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
Text.intercalate Text
"\n" ([Text] -> Text) -> (UTxO -> [Text]) -> UTxO -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TxIn, TxOut CtxUTxO Era) -> Text)
-> [(TxIn, TxOut CtxUTxO Era)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TxIn, TxOut CtxUTxO Era) -> Text
forall ctx era. (TxIn, TxOut ctx era) -> Text
UTxO.render ([(TxIn, TxOut CtxUTxO Era)] -> [Text])
-> (UTxO -> [(TxIn, TxOut CtxUTxO Era)]) -> UTxO -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO -> [(TxIn, TxOut CtxUTxO Era)]
forall out. UTxO' out -> [(TxIn, out)]
UTxO.pairs

-- | Construct a UTxO from a transaction. This constructs artificial `TxIn`
-- (a.k.a output reference) from the transaction itself, zipping them to the
-- outputs they correspond to.
utxoFromTx :: Tx Era -> UTxO
utxoFromTx :: Tx Era -> UTxO
utxoFromTx (Tx body :: TxBody Era
body@(ShelleyTxBody ShelleyBasedEra Era
_ TxBody LedgerEra
ledgerBody [Script LedgerEra]
_ TxBodyScriptData Era
_ Maybe (TxAuxData LedgerEra)
_ TxScriptValidity Era
_) [KeyWitness Era]
_) =
  let txOuts :: [TxOut (BabbageEra StandardCrypto)]
txOuts = StrictSeq (TxOut (BabbageEra StandardCrypto))
-> [TxOut (BabbageEra StandardCrypto)]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (StrictSeq (TxOut (BabbageEra StandardCrypto))
 -> [TxOut (BabbageEra StandardCrypto)])
-> StrictSeq (TxOut (BabbageEra StandardCrypto))
-> [TxOut (BabbageEra StandardCrypto)]
forall a b. (a -> b) -> a -> b
$ BabbageTxBody (BabbageEra StandardCrypto)
TxBody LedgerEra
ledgerBody BabbageTxBody (BabbageEra StandardCrypto)
-> Getting
     (StrictSeq (TxOut (BabbageEra StandardCrypto)))
     (BabbageTxBody (BabbageEra StandardCrypto))
     (StrictSeq (TxOut (BabbageEra StandardCrypto)))
-> StrictSeq (TxOut (BabbageEra StandardCrypto))
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictSeq (TxOut (BabbageEra StandardCrypto)))
  (BabbageTxBody (BabbageEra StandardCrypto))
  (StrictSeq (TxOut (BabbageEra StandardCrypto)))
(StrictSeq (TxOut (BabbageEra StandardCrypto))
 -> Const
      (StrictSeq (TxOut (BabbageEra StandardCrypto)))
      (StrictSeq (TxOut (BabbageEra StandardCrypto))))
-> TxBody (BabbageEra StandardCrypto)
-> Const
     (StrictSeq (TxOut (BabbageEra StandardCrypto)))
     (TxBody (BabbageEra StandardCrypto))
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens'
  (TxBody (BabbageEra StandardCrypto))
  (StrictSeq (TxOut (BabbageEra StandardCrypto)))
outputsTxBodyL
      txIns :: [TxIn StandardCrypto]
txIns =
        [ TxId StandardCrypto -> TxIx -> TxIn StandardCrypto
forall c. TxId c -> TxIx -> TxIn c
Ledger.TxIn (TxId -> TxId StandardCrypto
toLedgerTxId (TxId -> TxId StandardCrypto) -> TxId -> TxId StandardCrypto
forall a b. (a -> b) -> a -> b
$ TxBody Era -> TxId
forall era. TxBody era -> TxId
getTxId TxBody Era
body) TxIx
ix
        | TxIx
ix <- [Word64 -> TxIx
Ledger.TxIx Word64
0 .. Int -> TxIx
forall a. Enum a => Int -> a
toEnum ([TxOut (BabbageEra StandardCrypto)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TxOut (BabbageEra StandardCrypto)]
txOuts)]
        ]
   in UTxO LedgerEra -> UTxO
fromLedgerUTxO (UTxO LedgerEra -> UTxO) -> UTxO LedgerEra -> UTxO
forall a b. (a -> b) -> a -> b
$ Map (TxIn (EraCrypto LedgerEra)) (TxOut LedgerEra)
-> UTxO LedgerEra
forall era. Map (TxIn (EraCrypto era)) (TxOut era) -> UTxO era
Ledger.UTxO (Map (TxIn (EraCrypto LedgerEra)) (TxOut LedgerEra)
 -> UTxO LedgerEra)
-> Map (TxIn (EraCrypto LedgerEra)) (TxOut LedgerEra)
-> UTxO LedgerEra
forall a b. (a -> b) -> a -> b
$ [(TxIn (EraCrypto LedgerEra), TxOut LedgerEra)]
-> Map (TxIn (EraCrypto LedgerEra)) (TxOut LedgerEra)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(TxIn (EraCrypto LedgerEra), TxOut LedgerEra)]
 -> Map (TxIn (EraCrypto LedgerEra)) (TxOut LedgerEra))
-> [(TxIn (EraCrypto LedgerEra), TxOut LedgerEra)]
-> Map (TxIn (EraCrypto LedgerEra)) (TxOut LedgerEra)
forall a b. (a -> b) -> a -> b
$ [TxIn StandardCrypto]
-> [TxOut (BabbageEra StandardCrypto)]
-> [(TxIn StandardCrypto, TxOut (BabbageEra StandardCrypto))]
forall a b. [a] -> [b] -> [(a, b)]
zip [TxIn StandardCrypto]
txIns [TxOut (BabbageEra StandardCrypto)]
txOuts

-- | Resolve tx inputs in a given UTxO
resolveInputsUTxO :: UTxO -> Tx Era -> UTxO
resolveInputsUTxO :: UTxO -> Tx Era -> UTxO
resolveInputsUTxO UTxO
utxo Tx Era
tx =
  [(TxIn, TxOut CtxUTxO Era)] -> UTxO
forall out. [(TxIn, out)] -> UTxO' out
UTxO.fromPairs ([(TxIn, TxOut CtxUTxO Era)] -> UTxO)
-> [(TxIn, TxOut CtxUTxO Era)] -> UTxO
forall a b. (a -> b) -> a -> b
$
    (TxIn -> Maybe (TxIn, TxOut CtxUTxO Era))
-> [TxIn] -> [(TxIn, TxOut CtxUTxO Era)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\TxIn
txIn -> (TxIn
txIn,) (TxOut CtxUTxO Era -> (TxIn, TxOut CtxUTxO Era))
-> Maybe (TxOut CtxUTxO Era) -> Maybe (TxIn, TxOut CtxUTxO Era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TxIn -> UTxO -> Maybe (TxOut CtxUTxO Era)
forall out. TxIn -> UTxO' out -> Maybe out
UTxO.resolve TxIn
txIn UTxO
utxo) (Tx Era -> [TxIn]
forall era. Tx era -> [TxIn]
txIns' Tx Era
tx)

-- * Type Conversions

toLedgerUTxO :: UTxO -> Ledger.UTxO LedgerEra
toLedgerUTxO :: UTxO -> UTxO LedgerEra
toLedgerUTxO =
  Map
  (TxIn (EraCrypto (BabbageEra StandardCrypto)))
  (TxOut (BabbageEra StandardCrypto))
-> UTxO (BabbageEra StandardCrypto)
Map
  (TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto))
-> UTxO (BabbageEra StandardCrypto)
forall era. Map (TxIn (EraCrypto era)) (TxOut era) -> UTxO era
Ledger.UTxO (Map
   (TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto))
 -> UTxO (BabbageEra StandardCrypto))
-> (UTxO
    -> Map
         (TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto)))
-> UTxO
-> UTxO (BabbageEra StandardCrypto)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn
 -> TxOut CtxUTxO Era
 -> Map
      (TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto)))
-> Map TxIn (TxOut CtxUTxO Era)
-> Map
     (TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto))
forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
Map.foldMapWithKey TxIn
-> TxOut CtxUTxO Era
-> Map (TxIn StandardCrypto) (BabbageTxOut LedgerEra)
TxIn
-> TxOut CtxUTxO Era
-> Map
     (TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto))
fn (Map TxIn (TxOut CtxUTxO Era)
 -> Map
      (TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto)))
-> (UTxO -> Map TxIn (TxOut CtxUTxO Era))
-> UTxO
-> Map
     (TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO -> Map TxIn (TxOut CtxUTxO Era)
forall out. UTxO' out -> Map TxIn out
UTxO.toMap
 where
  fn ::
    TxIn ->
    TxOut CtxUTxO Era ->
    Map (Ledger.TxIn StandardCrypto) (Ledger.BabbageTxOut LedgerEra)
  fn :: TxIn
-> TxOut CtxUTxO Era
-> Map (TxIn StandardCrypto) (BabbageTxOut LedgerEra)
fn TxIn
i TxOut CtxUTxO Era
o =
    TxIn StandardCrypto
-> BabbageTxOut (BabbageEra StandardCrypto)
-> Map
     (TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto))
forall k a. k -> a -> Map k a
Map.singleton (TxIn -> TxIn StandardCrypto
toLedgerTxIn TxIn
i) (TxOut CtxUTxO Era -> TxOut LedgerEra
toLedgerTxOut TxOut CtxUTxO Era
o)

fromLedgerUTxO :: Ledger.UTxO LedgerEra -> UTxO
fromLedgerUTxO :: UTxO LedgerEra -> UTxO
fromLedgerUTxO =
  Map TxIn (TxOut CtxUTxO Era) -> UTxO
forall out. Map TxIn out -> UTxO' out
UTxO (Map TxIn (TxOut CtxUTxO Era) -> UTxO)
-> (UTxO (BabbageEra StandardCrypto)
    -> Map TxIn (TxOut CtxUTxO Era))
-> UTxO (BabbageEra StandardCrypto)
-> UTxO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn StandardCrypto
 -> BabbageTxOut (BabbageEra StandardCrypto)
 -> Map TxIn (TxOut CtxUTxO Era))
-> Map
     (TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto))
-> Map TxIn (TxOut CtxUTxO Era)
forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
Map.foldMapWithKey TxIn StandardCrypto
-> BabbageTxOut LedgerEra -> Map TxIn (TxOut CtxUTxO Era)
TxIn StandardCrypto
-> BabbageTxOut (BabbageEra StandardCrypto)
-> Map TxIn (TxOut CtxUTxO Era)
fn (Map
   (TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto))
 -> Map TxIn (TxOut CtxUTxO Era))
-> (UTxO (BabbageEra StandardCrypto)
    -> Map
         (TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto)))
-> UTxO (BabbageEra StandardCrypto)
-> Map TxIn (TxOut CtxUTxO Era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO (BabbageEra StandardCrypto)
-> Map
     (TxIn (EraCrypto (BabbageEra StandardCrypto)))
     (TxOut (BabbageEra StandardCrypto))
UTxO (BabbageEra StandardCrypto)
-> Map
     (TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto))
forall era. UTxO era -> Map (TxIn (EraCrypto era)) (TxOut era)
Ledger.unUTxO
 where
  fn ::
    Ledger.TxIn StandardCrypto ->
    Ledger.BabbageTxOut LedgerEra ->
    Map TxIn (TxOut CtxUTxO Era)
  fn :: TxIn StandardCrypto
-> BabbageTxOut LedgerEra -> Map TxIn (TxOut CtxUTxO Era)
fn TxIn StandardCrypto
i BabbageTxOut LedgerEra
o =
    TxIn -> TxOut CtxUTxO Era -> Map TxIn (TxOut CtxUTxO Era)
forall k a. k -> a -> Map k a
Map.singleton (TxIn StandardCrypto -> TxIn
fromLedgerTxIn TxIn StandardCrypto
i) (TxOut LedgerEra -> TxOut CtxUTxO Era
forall ctx. TxOut LedgerEra -> TxOut ctx Era
fromLedgerTxOut BabbageTxOut LedgerEra
TxOut LedgerEra
o)