module Hydra.Tx.Deposit where

import Hydra.Cardano.Api
import Hydra.Prelude hiding (toList)

import Cardano.Api.UTxO qualified as UTxO
import Cardano.Ledger.Api (AllegraEraTxBody (vldtTxBodyL), ValidityInterval (..), bodyTxL, outputsTxBodyL)
import Control.Lens ((.~))
import Data.Maybe.Strict (StrictMaybe (..))
import Data.Sequence.Strict qualified as StrictSeq
import GHC.IsList qualified as IsList
import Hydra.Contract.Commit qualified as Commit
import Hydra.Contract.Deposit qualified as Deposit
import Hydra.Plutus (depositValidatorScript)
import Hydra.Plutus.Extras.Time (posixFromUTCTime, posixToUTCTime)
import Hydra.Tx (CommitBlueprintTx (..), HeadId, currencySymbolToHeadId, headIdToCurrencySymbol, txId)
import Hydra.Tx.Utils (addMetadata, mkHydraHeadV2TxName)
import PlutusLedgerApi.V3 (POSIXTime)

-- * Construction

-- | Builds a deposit transaction to lock funds into the v_deposit script.
depositTx ::
  HasCallStack =>
  NetworkId ->
  PParams LedgerEra ->
  HeadId ->
  CommitBlueprintTx Tx ->
  -- | Slot to use as upper validity. Will mark the time of creation of the deposit.
  SlotNo ->
  -- | Deposit deadline from which onward the deposit can be recovered.
  UTCTime ->
  Maybe AddressInEra ->
  Tx
depositTx :: HasCallStack =>
NetworkId
-> PParams LedgerEra
-> HeadId
-> CommitBlueprintTx Tx
-> SlotNo
-> UTCTime
-> Maybe AddressInEra
-> Tx
depositTx NetworkId
networkId PParams LedgerEra
pparams HeadId
headId CommitBlueprintTx Tx
commitBlueprintTx SlotNo
upperSlot UTCTime
deadline Maybe AddressInEra
changeAddress =
  let blueprint :: Tx TopTx ConwayEra
blueprint =
        case Tx -> [TxOut CtxTx Era]
forall era. Tx era -> [TxOut CtxTx era]
txOuts' Tx
blueprintTx of
          [] ->
            -- When blueprint tx doesn't contain any outputs we just construct outputs taking the whole of lookupUTxO
            Tx -> Tx TopTx LedgerEra
forall era. Tx era -> Tx TopTx (ShelleyLedgerEra era)
toLedgerTx Tx
blueprintTx
              Tx TopTx ConwayEra
-> (Tx TopTx ConwayEra -> Tx TopTx ConwayEra) -> Tx TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxBody l ConwayEra)
bodyTxL ((TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> ((StrictSeq (BabbageTxOut ConwayEra)
     -> Identity (StrictSeq (BabbageTxOut ConwayEra)))
    -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> (StrictSeq (BabbageTxOut ConwayEra)
    -> Identity (StrictSeq (BabbageTxOut ConwayEra)))
-> Tx TopTx ConwayEra
-> Identity (Tx TopTx ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (BabbageTxOut ConwayEra)
 -> Identity (StrictSeq (BabbageTxOut ConwayEra)))
-> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra)
(StrictSeq (TxOut ConwayEra)
 -> Identity (StrictSeq (TxOut ConwayEra)))
-> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel).
Lens' (TxBody l ConwayEra) (StrictSeq (TxOut ConwayEra))
outputsTxBodyL
                ((StrictSeq (BabbageTxOut ConwayEra)
  -> Identity (StrictSeq (BabbageTxOut ConwayEra)))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> StrictSeq (BabbageTxOut ConwayEra)
-> Tx TopTx ConwayEra
-> Tx TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ BabbageTxOut ConwayEra -> StrictSeq (BabbageTxOut ConwayEra)
forall a. a -> StrictSeq a
StrictSeq.singleton (TxOut CtxUTxO Era -> TxOut LedgerEra
forall era.
(HasCallStack, IsShelleyBasedEra era) =>
TxOut CtxUTxO era -> TxOut (ShelleyLedgerEra era)
toLedgerTxOut (TxOut CtxUTxO Era -> TxOut LedgerEra)
-> TxOut CtxUTxO Era -> TxOut LedgerEra
forall a b. (a -> b) -> a -> b
$ NetworkId -> HeadId -> UTxO -> UTCTime -> TxOut CtxUTxO Era
forall ctx. NetworkId -> HeadId -> UTxO -> UTCTime -> TxOut ctx
mkDepositOutput NetworkId
networkId HeadId
headId UTxO
UTxOType Tx
lookupUTxO UTCTime
deadline)
          [TxOut CtxTx Era]
outs ->
            case Maybe AddressInEra
changeAddress of
              Maybe AddressInEra
Nothing ->
                -- In case change address is not specified we expect to see a fully balanced blueprint tx so we
                -- just take all the outputs and replace the `TxIn` to the blueprint one.
                Tx -> Tx TopTx LedgerEra
forall era. Tx era -> Tx TopTx (ShelleyLedgerEra era)
toLedgerTx Tx
blueprintTx
                  Tx TopTx ConwayEra
-> (Tx TopTx ConwayEra -> Tx TopTx ConwayEra) -> Tx TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxBody l ConwayEra)
bodyTxL ((TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> ((StrictSeq (BabbageTxOut ConwayEra)
     -> Identity (StrictSeq (BabbageTxOut ConwayEra)))
    -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> (StrictSeq (BabbageTxOut ConwayEra)
    -> Identity (StrictSeq (BabbageTxOut ConwayEra)))
-> Tx TopTx ConwayEra
-> Identity (Tx TopTx ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (BabbageTxOut ConwayEra)
 -> Identity (StrictSeq (BabbageTxOut ConwayEra)))
-> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra)
(StrictSeq (TxOut ConwayEra)
 -> Identity (StrictSeq (TxOut ConwayEra)))
-> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel).
Lens' (TxBody l ConwayEra) (StrictSeq (TxOut ConwayEra))
outputsTxBodyL
                    ((StrictSeq (BabbageTxOut ConwayEra)
  -> Identity (StrictSeq (BabbageTxOut ConwayEra)))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> StrictSeq (BabbageTxOut ConwayEra)
-> Tx TopTx ConwayEra
-> Tx TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ BabbageTxOut ConwayEra -> StrictSeq (BabbageTxOut ConwayEra)
forall a. a -> StrictSeq a
StrictSeq.singleton (TxOut CtxUTxO Era -> TxOut LedgerEra
forall era.
(HasCallStack, IsShelleyBasedEra era) =>
TxOut CtxUTxO era -> TxOut (ShelleyLedgerEra era)
toLedgerTxOut (TxOut CtxUTxO Era -> TxOut LedgerEra)
-> TxOut CtxUTxO Era -> TxOut LedgerEra
forall a b. (a -> b) -> a -> b
$ NetworkId -> HeadId -> UTxO -> UTCTime -> TxOut CtxUTxO Era
forall ctx. NetworkId -> HeadId -> UTxO -> UTCTime -> TxOut ctx
mkDepositOutput NetworkId
networkId HeadId
headId (TxId -> [TxOut CtxTx Era] -> UTxO
constructDepositUTxO (TxBody Era -> TxId
forall era. TxBody era -> TxId
getTxId (TxBody Era -> TxId) -> TxBody Era -> TxId
forall a b. (a -> b) -> a -> b
$ Tx -> TxBody Era
forall era. Tx era -> TxBody era
getTxBody Tx
blueprintTx) [TxOut CtxTx Era]
outs) UTCTime
deadline)
              Just AddressInEra
addr ->
                -- When change address is specified we balance the blueprint tx ourselves adding the change output to return to the user.
                let depositOutput :: TxOut LedgerEra
depositOutput =
                      TxOut CtxUTxO Era -> TxOut LedgerEra
forall era.
(HasCallStack, IsShelleyBasedEra era) =>
TxOut CtxUTxO era -> TxOut (ShelleyLedgerEra era)
toLedgerTxOut (TxOut CtxUTxO Era -> TxOut LedgerEra)
-> TxOut CtxUTxO Era -> TxOut LedgerEra
forall a b. (a -> b) -> a -> b
$
                        NetworkId -> HeadId -> UTxO -> UTCTime -> TxOut CtxUTxO Era
forall ctx. NetworkId -> HeadId -> UTxO -> UTCTime -> TxOut ctx
mkDepositOutput NetworkId
networkId HeadId
headId (TxId -> [TxOut CtxTx Era] -> UTxO
constructDepositUTxO (TxBody Era -> TxId
forall era. TxBody era -> TxId
getTxId (TxBody Era -> TxId) -> TxBody Era -> TxId
forall a b. (a -> b) -> a -> b
$ Tx -> TxBody Era
forall era. Tx era -> TxBody era
getTxBody Tx
blueprintTx) [TxOut CtxTx Era]
outs) UTCTime
deadline

                    balance :: UTxO -> TxBody Era -> TxOutValue Era
balance = ShelleyBasedEra Era
-> PParams LedgerEra
-> Set PoolId
-> Map StakeCredential Coin
-> Map (Credential DRepRole) Coin
-> UTxO
-> TxBody Era
-> TxOutValue Era
forall era.
ShelleyBasedEra era
-> PParams (ShelleyLedgerEra era)
-> Set PoolId
-> Map StakeCredential Coin
-> Map (Credential DRepRole) Coin
-> UTxO era
-> TxBody era
-> TxOutValue era
evaluateTransactionBalance ShelleyBasedEra Era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra PParams LedgerEra
pparams Set PoolId
forall a. Monoid a => a
mempty Map StakeCredential Coin
forall a. Monoid a => a
mempty Map (Credential DRepRole) Coin
forall a. Monoid a => a
mempty

                    partialTx :: Tx
partialTx =
                      Tx TopTx LedgerEra -> Tx
forall era.
IsShelleyBasedEra era =>
Tx TopTx (ShelleyLedgerEra era) -> Tx era
fromLedgerTx (Tx TopTx LedgerEra -> Tx) -> Tx TopTx LedgerEra -> Tx
forall a b. (a -> b) -> a -> b
$
                        Tx -> Tx TopTx LedgerEra
forall era. Tx era -> Tx TopTx (ShelleyLedgerEra era)
toLedgerTx Tx
blueprintTx
                          Tx TopTx ConwayEra
-> (Tx TopTx ConwayEra -> Tx TopTx ConwayEra) -> Tx TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxBody l ConwayEra)
bodyTxL ((TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> ((StrictSeq (BabbageTxOut ConwayEra)
     -> Identity (StrictSeq (BabbageTxOut ConwayEra)))
    -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> (StrictSeq (BabbageTxOut ConwayEra)
    -> Identity (StrictSeq (BabbageTxOut ConwayEra)))
-> Tx TopTx ConwayEra
-> Identity (Tx TopTx ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (BabbageTxOut ConwayEra)
 -> Identity (StrictSeq (BabbageTxOut ConwayEra)))
-> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra)
(StrictSeq (TxOut ConwayEra)
 -> Identity (StrictSeq (TxOut ConwayEra)))
-> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel).
Lens' (TxBody l ConwayEra) (StrictSeq (TxOut ConwayEra))
outputsTxBodyL ((StrictSeq (BabbageTxOut ConwayEra)
  -> Identity (StrictSeq (BabbageTxOut ConwayEra)))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> StrictSeq (BabbageTxOut ConwayEra)
-> Tx TopTx ConwayEra
-> Tx TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ BabbageTxOut ConwayEra -> StrictSeq (BabbageTxOut ConwayEra)
forall a. a -> StrictSeq a
StrictSeq.singleton BabbageTxOut ConwayEra
TxOut LedgerEra
depositOutput

                    completeUTxO :: UTxO
completeUTxO = UTxO -> Tx -> UTxO
resolveInputsUTxO UTxO
UTxOType Tx
lookupUTxO Tx
blueprintTx

                    leftoverValue :: Value
leftoverValue = Value -> Value
capNegative (Value -> Value)
-> (TxOutValue Era -> Value) -> TxOutValue Era -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOutValue Era -> Value
forall era. TxOutValue era -> Value
txOutValueToValue (TxOutValue Era -> Value) -> TxOutValue Era -> Value
forall a b. (a -> b) -> a -> b
$ UTxO -> TxBody Era -> TxOutValue Era
balance UTxO
completeUTxO (Tx -> TxBody Era
forall era. Tx era -> TxBody era
getTxBody Tx
partialTx)

                    capNegative :: Value -> Value
capNegative =
                      [(AssetId, Quantity)] -> Value
[Item Value] -> Value
forall l. IsList l => [Item l] -> l
fromList ([(AssetId, Quantity)] -> Value)
-> (Value -> [(AssetId, Quantity)]) -> Value -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((AssetId, Quantity) -> (AssetId, Quantity))
-> [(AssetId, Quantity)] -> [(AssetId, Quantity)]
forall a b. (a -> b) -> [a] -> [b]
map ((Quantity -> Quantity)
-> (AssetId, Quantity) -> (AssetId, Quantity)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Quantity -> Quantity -> Quantity
forall a. Ord a => a -> a -> a
max Quantity
0)) ([(AssetId, Quantity)] -> [(AssetId, Quantity)])
-> (Value -> [(AssetId, Quantity)])
-> Value
-> [(AssetId, Quantity)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> [(AssetId, Quantity)]
Value -> [Item Value]
forall l. IsList l => l -> [Item l]
IsList.toList

                    changeOutput :: TxOut LedgerEra
changeOutput = TxOut CtxUTxO Era -> TxOut LedgerEra
forall era.
(HasCallStack, IsShelleyBasedEra era) =>
TxOut CtxUTxO era -> TxOut (ShelleyLedgerEra era)
toLedgerTxOut (TxOut CtxUTxO Era -> TxOut LedgerEra)
-> TxOut CtxUTxO Era -> TxOut LedgerEra
forall a b. (a -> b) -> a -> b
$ AddressInEra
-> Value
-> TxOutDatum CtxUTxO
-> ReferenceScript
-> TxOut CtxUTxO Era
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut AddressInEra
addr Value
leftoverValue TxOutDatum CtxUTxO
forall ctx. TxOutDatum ctx
TxOutDatumNone ReferenceScript
ReferenceScriptNone
                 in Tx -> Tx TopTx LedgerEra
forall era. Tx era -> Tx TopTx (ShelleyLedgerEra era)
toLedgerTx Tx
partialTx
                      Tx TopTx ConwayEra
-> (Tx TopTx ConwayEra -> Tx TopTx ConwayEra) -> Tx TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxBody l ConwayEra)
bodyTxL ((TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> ((StrictSeq (BabbageTxOut ConwayEra)
     -> Identity (StrictSeq (BabbageTxOut ConwayEra)))
    -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> (StrictSeq (BabbageTxOut ConwayEra)
    -> Identity (StrictSeq (BabbageTxOut ConwayEra)))
-> Tx TopTx ConwayEra
-> Identity (Tx TopTx ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (BabbageTxOut ConwayEra)
 -> Identity (StrictSeq (BabbageTxOut ConwayEra)))
-> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra)
(StrictSeq (TxOut ConwayEra)
 -> Identity (StrictSeq (TxOut ConwayEra)))
-> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel).
Lens' (TxBody l ConwayEra) (StrictSeq (TxOut ConwayEra))
outputsTxBodyL
                        ((StrictSeq (BabbageTxOut ConwayEra)
  -> Identity (StrictSeq (BabbageTxOut ConwayEra)))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> StrictSeq (BabbageTxOut ConwayEra)
-> Tx TopTx ConwayEra
-> Tx TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [BabbageTxOut ConwayEra] -> StrictSeq (BabbageTxOut ConwayEra)
forall a. [a] -> StrictSeq a
StrictSeq.fromList [BabbageTxOut ConwayEra
TxOut LedgerEra
depositOutput, BabbageTxOut ConwayEra
TxOut LedgerEra
changeOutput]
   in Tx TopTx LedgerEra -> Tx
forall era.
IsShelleyBasedEra era =>
Tx TopTx (ShelleyLedgerEra era) -> Tx era
fromLedgerTx (Tx TopTx LedgerEra -> Tx) -> Tx TopTx LedgerEra -> Tx
forall a b. (a -> b) -> a -> b
$
        Tx TopTx ConwayEra
blueprint
          Tx TopTx ConwayEra
-> (Tx TopTx ConwayEra -> Tx TopTx ConwayEra) -> Tx TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxBody l ConwayEra)
bodyTxL ((TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> ((ValidityInterval -> Identity ValidityInterval)
    -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> (ValidityInterval -> Identity ValidityInterval)
-> Tx TopTx ConwayEra
-> Identity (Tx TopTx ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ValidityInterval -> Identity ValidityInterval)
-> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
AllegraEraTxBody era =>
Lens' (TxBody l era) ValidityInterval
forall (l :: TxLevel). Lens' (TxBody l ConwayEra) ValidityInterval
vldtTxBodyL ((ValidityInterval -> Identity ValidityInterval)
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> ValidityInterval -> Tx TopTx ConwayEra -> Tx TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ValidityInterval{invalidBefore :: StrictMaybe SlotNo
invalidBefore = StrictMaybe SlotNo
forall a. StrictMaybe a
SNothing, invalidHereafter :: StrictMaybe SlotNo
invalidHereafter = SlotNo -> StrictMaybe SlotNo
forall a. a -> StrictMaybe a
SJust SlotNo
upperSlot}
          Tx TopTx ConwayEra
-> (Tx TopTx ConwayEra -> Tx TopTx ConwayEra) -> Tx TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& TxMetadata -> Tx -> Tx TopTx LedgerEra -> Tx TopTx LedgerEra
addMetadata (Text -> TxMetadata
mkHydraHeadV2TxName Text
"DepositTx") Tx
blueprintTx
 where
  CommitBlueprintTx{UTxOType Tx
lookupUTxO :: UTxOType Tx
$sel:lookupUTxO:CommitBlueprintTx :: forall tx. CommitBlueprintTx tx -> UTxOType tx
lookupUTxO, Tx
blueprintTx :: Tx
$sel:blueprintTx:CommitBlueprintTx :: forall tx. CommitBlueprintTx tx -> tx
blueprintTx} = CommitBlueprintTx Tx
commitBlueprintTx

mkDepositOutput ::
  NetworkId ->
  HeadId ->
  UTxO ->
  UTCTime ->
  TxOut ctx
mkDepositOutput :: forall ctx. NetworkId -> HeadId -> UTxO -> UTCTime -> TxOut ctx
mkDepositOutput NetworkId
networkId HeadId
headId UTxO
depositUTxO UTCTime
deadline =
  AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut
    (NetworkId -> AddressInEra
depositAddress NetworkId
networkId)
    Value
depositValue
    TxOutDatum ctx
depositDatum
    ReferenceScript
ReferenceScriptNone
 where
  depositValue :: Value
depositValue = UTxO -> Value
forall era. UTxO era -> Value
UTxO.totalValue UTxO
depositUTxO

  deposits :: [Commit]
deposits = ((TxIn, TxOut CtxUTxO Era) -> Maybe Commit)
-> [(TxIn, TxOut CtxUTxO Era)] -> [Commit]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (TxIn, TxOut CtxUTxO Era) -> Maybe Commit
Commit.serializeCommit ([(TxIn, TxOut CtxUTxO Era)] -> [Commit])
-> [(TxIn, TxOut CtxUTxO Era)] -> [Commit]
forall a b. (a -> b) -> a -> b
$ UTxO -> [(TxIn, TxOut CtxUTxO Era)]
forall era. UTxO era -> [(TxIn, TxOut CtxUTxO era)]
UTxO.toList UTxO
depositUTxO

  depositPlutusDatum :: Datum
depositPlutusDatum = (CurrencySymbol, POSIXTime, [Commit]) -> Datum
Deposit.datum (HeadId -> CurrencySymbol
headIdToCurrencySymbol HeadId
headId, UTCTime -> POSIXTime
posixFromUTCTime UTCTime
deadline, [Commit]
deposits)

  depositDatum :: TxOutDatum ctx
depositDatum = Datum -> TxOutDatum ctx
forall era a ctx.
(ToScriptData a, IsBabbageBasedEra era) =>
a -> TxOutDatum ctx era
mkTxOutDatumInline Datum
depositPlutusDatum

constructDepositUTxO :: TxId -> [TxOut CtxTx] -> UTxO
constructDepositUTxO :: TxId -> [TxOut CtxTx Era] -> UTxO
constructDepositUTxO TxId
txid [TxOut CtxTx Era]
outputs =
  [(TxIn, TxOut CtxUTxO Era)] -> UTxO
forall era. [(TxIn, TxOut CtxUTxO era)] -> UTxO era
UTxO.fromList ([(TxIn, TxOut CtxUTxO Era)] -> UTxO)
-> [(TxIn, TxOut CtxUTxO Era)] -> UTxO
forall a b. (a -> b) -> a -> b
$ (\(TxOut CtxTx Era
txOut, Word
n) -> (TxId -> TxIx -> TxIn
TxIn TxId
txid (Word -> TxIx
TxIx Word
n), TxOut CtxTx Era -> TxOut CtxUTxO Era
forall era. TxOut CtxTx era -> TxOut CtxUTxO era
toCtxUTxOTxOut TxOut CtxTx Era
txOut)) ((TxOut CtxTx Era, Word) -> (TxIn, TxOut CtxUTxO Era))
-> [(TxOut CtxTx Era, Word)] -> [(TxIn, TxOut CtxUTxO Era)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TxOut CtxTx Era] -> [Word] -> [(TxOut CtxTx Era, Word)]
forall a b. [a] -> [b] -> [(a, b)]
zip [TxOut CtxTx Era]
outputs [Word
0 .. Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([TxOut CtxTx Era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TxOut CtxTx Era]
outputs)]

depositAddress :: NetworkId -> AddressInEra
depositAddress :: NetworkId -> AddressInEra
depositAddress NetworkId
networkId = NetworkId -> PlutusScript PlutusScriptV3 -> AddressInEra
forall lang era.
(IsShelleyBasedEra era, IsPlutusScriptLanguage lang) =>
NetworkId -> PlutusScript lang -> AddressInEra era
mkScriptAddress NetworkId
networkId PlutusScript PlutusScriptV3
depositValidatorScript

-- * Observation

data DepositObservation = DepositObservation
  { DepositObservation -> HeadId
headId :: HeadId
  , DepositObservation -> TxId
depositTxId :: TxId
  , DepositObservation -> UTxO
deposited :: UTxO
  , DepositObservation -> SlotNo
created :: SlotNo
  , DepositObservation -> UTCTime
deadline :: UTCTime
  }
  deriving stock (Int -> DepositObservation -> ShowS
[DepositObservation] -> ShowS
DepositObservation -> String
(Int -> DepositObservation -> ShowS)
-> (DepositObservation -> String)
-> ([DepositObservation] -> ShowS)
-> Show DepositObservation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DepositObservation -> ShowS
showsPrec :: Int -> DepositObservation -> ShowS
$cshow :: DepositObservation -> String
show :: DepositObservation -> String
$cshowList :: [DepositObservation] -> ShowS
showList :: [DepositObservation] -> ShowS
Show, DepositObservation -> DepositObservation -> Bool
(DepositObservation -> DepositObservation -> Bool)
-> (DepositObservation -> DepositObservation -> Bool)
-> Eq DepositObservation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DepositObservation -> DepositObservation -> Bool
== :: DepositObservation -> DepositObservation -> Bool
$c/= :: DepositObservation -> DepositObservation -> Bool
/= :: DepositObservation -> DepositObservation -> Bool
Eq, (forall x. DepositObservation -> Rep DepositObservation x)
-> (forall x. Rep DepositObservation x -> DepositObservation)
-> Generic DepositObservation
forall x. Rep DepositObservation x -> DepositObservation
forall x. DepositObservation -> Rep DepositObservation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. DepositObservation -> Rep DepositObservation x
from :: forall x. DepositObservation -> Rep DepositObservation x
$cto :: forall x. Rep DepositObservation x -> DepositObservation
to :: forall x. Rep DepositObservation x -> DepositObservation
Generic)
  deriving anyclass ([DepositObservation] -> Value
[DepositObservation] -> Encoding
DepositObservation -> Bool
DepositObservation -> Value
DepositObservation -> Encoding
(DepositObservation -> Value)
-> (DepositObservation -> Encoding)
-> ([DepositObservation] -> Value)
-> ([DepositObservation] -> Encoding)
-> (DepositObservation -> Bool)
-> ToJSON DepositObservation
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: DepositObservation -> Value
toJSON :: DepositObservation -> Value
$ctoEncoding :: DepositObservation -> Encoding
toEncoding :: DepositObservation -> Encoding
$ctoJSONList :: [DepositObservation] -> Value
toJSONList :: [DepositObservation] -> Value
$ctoEncodingList :: [DepositObservation] -> Encoding
toEncodingList :: [DepositObservation] -> Encoding
$comitField :: DepositObservation -> Bool
omitField :: DepositObservation -> Bool
ToJSON, Maybe DepositObservation
Value -> Parser [DepositObservation]
Value -> Parser DepositObservation
(Value -> Parser DepositObservation)
-> (Value -> Parser [DepositObservation])
-> Maybe DepositObservation
-> FromJSON DepositObservation
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser DepositObservation
parseJSON :: Value -> Parser DepositObservation
$cparseJSONList :: Value -> Parser [DepositObservation]
parseJSONList :: Value -> Parser [DepositObservation]
$comittedField :: Maybe DepositObservation
omittedField :: Maybe DepositObservation
FromJSON)

-- | Observe a deposit transaction by decoding the target head id, deposit
-- deadline and deposited utxo in the datum.
--
-- This includes checking whether
-- - the transaction's first output is the deposit output
-- - all of deposited value is contained in the deposit tx output,
-- - the deposit script output actually contains the deposited value,
-- - an upper validity bound has been set (used as creation slot).
observeDepositTx ::
  NetworkId ->
  Tx ->
  Maybe DepositObservation
observeDepositTx :: NetworkId -> Tx -> Maybe DepositObservation
observeDepositTx NetworkId
networkId Tx
tx = do
  (TxIn TxId
_ TxIx
depositIx, TxOut CtxTx Era
depositOut) <- AddressInEra -> Tx -> Maybe (TxIn, TxOut CtxTx Era)
forall era.
AddressInEra era -> Tx era -> Maybe (TxIn, TxOut CtxTx era)
findTxOutByAddress (NetworkId -> AddressInEra
depositAddress NetworkId
networkId) Tx
tx
  -- A deposit is identified by its transaction id alone, which only works
  -- because it is that transaction's first output: 'depositTx' builds it there,
  -- 'recoverTx' spends @TxIn depositTxId (TxIx 0)@, and the increment validator
  -- requires it. Observing one at any other index would let parties sign a
  -- snapshot committing a deposit that can then neither be claimed nor
  -- recovered.
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ TxIx
depositIx TxIx -> TxIx -> Bool
forall a. Eq a => a -> a -> Bool
== Word -> TxIx
TxIx Word
0
  (HeadId
headId, UTxO
deposited, POSIXTime
deadline) <- Network -> TxOut CtxUTxO Era -> Maybe (HeadId, UTxO, POSIXTime)
observeDepositTxOut Network
network (TxOut CtxTx Era -> TxOut CtxUTxO Era
forall era. TxOut CtxTx era -> TxOut CtxUTxO era
toCtxUTxOTxOut TxOut CtxTx Era
depositOut)
  SlotNo
created <- Maybe SlotNo
getUpperBound
  DepositObservation -> Maybe DepositObservation
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    DepositObservation
      { HeadId
$sel:headId:DepositObservation :: HeadId
headId :: HeadId
headId
      , $sel:depositTxId:DepositObservation :: TxId
depositTxId = Tx -> TxIdType Tx
forall tx. IsTx tx => tx -> TxIdType tx
Hydra.Tx.txId Tx
tx
      , UTxO
$sel:deposited:DepositObservation :: UTxO
deposited :: UTxO
deposited
      , SlotNo
$sel:created:DepositObservation :: SlotNo
created :: SlotNo
created
      , $sel:deadline:DepositObservation :: UTCTime
deadline = POSIXTime -> UTCTime
posixToUTCTime POSIXTime
deadline
      }
 where
  getUpperBound :: Maybe SlotNo
getUpperBound =
    case Tx
tx Tx -> (Tx -> TxBody Era) -> TxBody Era
forall a b. a -> (a -> b) -> b
& Tx -> TxBody Era
forall era. Tx era -> TxBody era
getTxBody TxBody Era
-> (TxBody Era -> TxBodyContent ViewTx Era)
-> TxBodyContent ViewTx Era
forall a b. a -> (a -> b) -> b
& TxBody Era -> TxBodyContent ViewTx Era
forall era. TxBody era -> TxBodyContent ViewTx era
getTxBodyContent TxBodyContent ViewTx Era
-> (TxBodyContent ViewTx Era -> TxValidityUpperBound)
-> TxValidityUpperBound
forall a b. a -> (a -> b) -> b
& TxBodyContent ViewTx Era -> TxValidityUpperBound
forall build. TxBodyContent build -> TxValidityUpperBound
txValidityUpperBound of
      TxValidityUpperBound{SlotNo
upperBound :: SlotNo
upperBound :: TxValidityUpperBound -> SlotNo
upperBound} -> SlotNo -> Maybe SlotNo
forall a. a -> Maybe a
Just SlotNo
upperBound
      TxValidityUpperBound
TxValidityNoUpperBound -> Maybe SlotNo
forall a. Maybe a
Nothing

  network :: Network
network = NetworkId -> Network
toShelleyNetwork NetworkId
networkId

observeDepositTxOut :: Network -> TxOut CtxUTxO -> Maybe (HeadId, UTxO, POSIXTime)
observeDepositTxOut :: Network -> TxOut CtxUTxO Era -> Maybe (HeadId, UTxO, POSIXTime)
observeDepositTxOut Network
network TxOut CtxUTxO Era
depositOut = do
  HashableScriptData
dat <- case TxOut CtxUTxO Era -> TxOutDatum CtxUTxO
forall ctx. TxOut ctx -> TxOutDatum ctx
txOutDatum TxOut CtxUTxO Era
depositOut of
    TxOutDatumInline HashableScriptData
d -> HashableScriptData -> Maybe HashableScriptData
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HashableScriptData
d
    TxOutDatum CtxUTxO
_ -> Maybe HashableScriptData
forall a. Maybe a
Nothing
  (CurrencySymbol
headCurrencySymbol, POSIXTime
deadline, [Commit]
onChainDeposits) <- HashableScriptData -> Maybe (CurrencySymbol, POSIXTime, [Commit])
forall a. FromScriptData a => HashableScriptData -> Maybe a
fromScriptData HashableScriptData
dat
  HeadId
headId <- CurrencySymbol -> Maybe HeadId
forall (m :: * -> *). MonadFail m => CurrencySymbol -> m HeadId
currencySymbolToHeadId CurrencySymbol
headCurrencySymbol
  UTxO
deposit <- do
    -- Force the decoded UTxO: this decode (plutus 'Data' via 'deserializeCommit') is an
    -- ingress point for 'UTxO' that the forcing 'FromJSON'/'FromCBOR' instances do not
    -- cover, and the observed set flows into 'localUTxO' and snapshots where
    -- 'forceNewEntries' deliberately trusts carried-over entries. Today the round-trip
    -- guard in 'deserializeRoundTripping' happens to force the entries deeply as a side
    -- effect of re-serializing them; forcing explicitly here makes the ingress invariant
    -- survive a refactor of that guard (and the observation test asserts it).
    UTxO
depositedUTxO <- UTxO -> UTxO
forceUTxO (UTxO -> UTxO)
-> ([(TxIn, TxOut CtxUTxO Era)] -> UTxO)
-> [(TxIn, TxOut CtxUTxO Era)]
-> UTxO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(TxIn, TxOut CtxUTxO Era)] -> UTxO
forall era. [(TxIn, TxOut CtxUTxO era)] -> UTxO era
UTxO.fromList ([(TxIn, TxOut CtxUTxO Era)] -> UTxO)
-> Maybe [(TxIn, TxOut CtxUTxO Era)] -> Maybe UTxO
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Commit -> Maybe (TxIn, TxOut CtxUTxO Era))
-> [Commit] -> Maybe [(TxIn, TxOut CtxUTxO Era)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Commit -> Maybe (TxIn, TxOut CtxUTxO Era)
deserializeRoundTripping [Commit]
onChainDeposits
    -- TODO: This silently ignores deposits that deposit less ADA than what the
    -- min ADA for the deposit output would be. For example: a 1 ADA utxo can be
    -- deposited, but the deposit tx's output will require ~1.5 ADA because of
    -- the inline datum on it. Dropping this or changing to a >= here will not
    -- work because the increment redeemer of the head validator requires an
    -- exact balance (right now).
    -- 'UTxO.fromList' is keyed by 'TxIn', so commits repeating an input collapse
    -- into one entry. Each such commit round-trips fine on its own and the value
    -- guard below can be satisfied against the collapsed total, but the validators
    -- hash the datum's list as it stands — two copies of the same bytes — so
    -- nothing derived from this UTxO could ever match, leaving the deposit neither
    -- claimable nor recoverable.
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ [Commit] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Commit]
onChainDeposits Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== UTxO -> Int
forall era. UTxO era -> Int
UTxO.size UTxO
depositedUTxO
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Value
depositValue Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== UTxO -> Value
forall era. UTxO era -> Value
UTxO.totalValue UTxO
depositedUTxO
    UTxO -> Maybe UTxO
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UTxO
depositedUTxO
  (HeadId, UTxO, POSIXTime) -> Maybe (HeadId, UTxO, POSIXTime)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HeadId
headId, UTxO
deposit, POSIXTime
deadline)
 where
  depositValue :: Value
depositValue = TxOut CtxUTxO Era -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO Era
depositOut

  -- The validators hash the datum's 'preSerializedOutput' bytes as they stand,
  -- while the off-chain representation cannot express everything those bytes can:
  -- 'fromPlutusTxOut' drops a reference script, for instance. A deposit whose
  -- commits do not survive the round trip would still be observed and committed by
  -- a snapshot, but every hash recomputed from the off-chain UTxO would differ from
  -- the datum's — leaving it neither claimable by an increment nor recoverable,
  -- since 'recoverTx' rebuilds its outputs through the same lossy path. Refuse to
  -- observe such a deposit; the funds stay recoverable by a transaction that
  -- reproduces the original outputs exactly.
  deserializeRoundTripping :: Commit -> Maybe (TxIn, TxOut CtxUTxO Era)
deserializeRoundTripping Commit
commit = do
    (TxIn
i, TxOut CtxUTxO Era
o) <- Network -> Commit -> Maybe (TxIn, TxOut CtxUTxO Era)
Commit.deserializeCommit Network
network Commit
commit
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ (TxIn, TxOut CtxUTxO Era) -> Maybe Commit
Commit.serializeCommit (TxIn
i, TxOut CtxUTxO Era
o) Maybe Commit -> Maybe Commit -> Bool
forall a. Eq a => a -> a -> Bool
== Commit -> Maybe Commit
forall a. a -> Maybe a
Just Commit
commit
    (TxIn, TxOut CtxUTxO Era) -> Maybe (TxIn, TxOut CtxUTxO Era)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxIn
i, TxOut CtxUTxO Era
o)