module Hydra.Tx.Deposit where

import Hydra.Prelude

import Cardano.Api.UTxO qualified as UTxO
import Hydra.Cardano.Api
import Hydra.Contract.Commit qualified as Commit
import Hydra.Contract.Deposit qualified as Deposit
import Hydra.Ledger.Cardano.Builder (
  addInputs,
  addOutputs,
  emptyTxBody,
  unsafeBuildTransaction,
 )
import Hydra.Plutus.Extras.Time (posixFromUTCTime)
import Hydra.Tx (HeadId, headIdToCurrencySymbol)

-- | Builds a deposit transaction to lock funds into the v_deposit script.
depositTx ::
  NetworkId ->
  HeadId ->
  -- | UTxO to deposit
  UTxO ->
  -- | Deposit deadline
  UTCTime ->
  Tx
depositTx :: NetworkId -> HeadId -> UTxO -> UTCTime -> Tx
depositTx NetworkId
networkId HeadId
headId UTxO
depositUTxO UTCTime
deadline =
  HasCallStack => TxBodyContent BuildTx -> Tx
TxBodyContent BuildTx -> Tx
unsafeBuildTransaction (TxBodyContent BuildTx -> Tx) -> TxBodyContent BuildTx -> Tx
forall a b. (a -> b) -> a -> b
$
    TxBodyContent BuildTx
emptyTxBody
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& TxIns BuildTx -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addInputs TxIns BuildTx
depositInputs
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [TxOut CtxTx] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addOutputs [TxOut CtxTx
depositOutput]
 where
  depositInputsList :: [TxIn]
depositInputsList = Set TxIn -> [TxIn]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (UTxO -> Set TxIn
forall out. UTxO' out -> Set TxIn
UTxO.inputSet UTxO
depositUTxO)

  depositInputs :: TxIns BuildTx
depositInputs = (,Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn))
-> Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn)
forall a b. (a -> b) -> a -> b
$ KeyWitnessInCtx WitCtxTxIn -> Witness WitCtxTxIn
forall ctx. KeyWitnessInCtx ctx -> Witness ctx
KeyWitness KeyWitnessInCtx WitCtxTxIn
KeyWitnessForSpending) (TxIn -> (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn)))
-> [TxIn] -> TxIns BuildTx
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TxIn]
depositInputsList

  depositValue :: Value
depositValue = (TxOut CtxUTxO -> Value) -> UTxO -> Value
forall m a. Monoid m => (a -> m) -> UTxO' a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue UTxO
depositUTxO

  depositScript :: PlutusScript PlutusScriptV2
depositScript = forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV2 SerialisedScript
Deposit.validatorScript

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

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

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

  depositOutput :: TxOut CtxTx
depositOutput =
    AddressInEra
-> Value -> TxOutDatum CtxTx Era -> ReferenceScript -> TxOut CtxTx
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut
      (forall lang era.
(IsShelleyBasedEra era, IsPlutusScriptLanguage lang) =>
NetworkId -> PlutusScript lang -> AddressInEra era
mkScriptAddress @PlutusScriptV2 NetworkId
networkId PlutusScript PlutusScriptV2
depositScript)
      Value
depositValue
      TxOutDatum CtxTx Era
depositDatum
      ReferenceScript
ReferenceScriptNone