module Hydra.Tx.Increment where

import Hydra.Cardano.Api
import Hydra.Prelude

import Cardano.Api.UTxO qualified as UTxO
import Data.List qualified as List
import Hydra.Contract.Deposit qualified as Deposit
import Hydra.Contract.Head qualified as Head
import Hydra.Contract.HeadState qualified as Head
import Hydra.Ledger.Cardano.Builder (
  unsafeBuildTransaction,
 )
import Hydra.Plutus (depositValidatorScript)
import Hydra.Tx.ContestationPeriod (toChain)
import Hydra.Tx.Crypto (MultiSignature (..), toPlutusSignatures)
import Hydra.Tx.HeadId (HeadId, headIdToCurrencySymbol)
import Hydra.Tx.HeadParameters (HeadParameters (..))
import Hydra.Tx.IsTx (hashUTxO)
import Hydra.Tx.Party (partyToChain)
import Hydra.Tx.ScriptRegistry (ScriptRegistry, headReference)
import Hydra.Tx.Snapshot (Snapshot (..))
import Hydra.Tx.Utils (mkHydraHeadV1TxName)
import PlutusLedgerApi.V3 (toBuiltin)

-- | Construct a _increment_ transaction which takes as input some 'UTxO'
-- locked at v_deposit and make it available on L2.
incrementTx ::
  -- | Published Hydra scripts to reference.
  ScriptRegistry ->
  -- | Party who's authorizing this transaction
  VerificationKey PaymentKey ->
  -- | Head identifier
  HeadId ->
  -- | Parameters of the head.
  HeadParameters ->
  -- | Everything needed to spend the Head state-machine output.
  (TxIn, TxOut CtxUTxO) ->
  -- | Confirmed Snapshot
  Snapshot Tx ->
  -- | Deposit output UTxO to be spent in increment transaction
  UTxO ->
  SlotNo ->
  MultiSignature (Snapshot Tx) ->
  Tx
incrementTx :: ScriptRegistry
-> VerificationKey PaymentKey
-> HeadId
-> HeadParameters
-> (TxIn, TxOut CtxUTxO)
-> Snapshot Tx
-> UTxO' (TxOut CtxUTxO)
-> SlotNo
-> MultiSignature (Snapshot Tx)
-> Tx
incrementTx ScriptRegistry
scriptRegistry VerificationKey PaymentKey
vk HeadId
headId HeadParameters
headParameters (TxIn
headInput, TxOut CtxUTxO
headOutput) Snapshot Tx
snapshot UTxO' (TxOut CtxUTxO)
depositScriptUTxO SlotNo
upperValiditySlot MultiSignature (Snapshot Tx)
sigs =
  HasCallStack => TxBodyContent BuildTx -> Tx
TxBodyContent BuildTx -> Tx
unsafeBuildTransaction (TxBodyContent BuildTx -> Tx) -> TxBodyContent BuildTx -> Tx
forall a b. (a -> b) -> a -> b
$
    TxBodyContent BuildTx
defaultTxBodyContent
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& TxIns BuildTx Era -> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall build era.
TxIns build era
-> TxBodyContent build era -> TxBodyContent build era
addTxIns [(TxIn
headInput, BuildTxWith BuildTx (Witness WitCtxTxIn)
headWitness), (TxIn
depositIn, BuildTxWith BuildTx (Witness WitCtxTxIn)
depositWitness)]
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [TxIn] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall era build.
IsBabbageBasedEra era =>
[TxIn] -> TxBodyContent build era -> TxBodyContent build era
addTxInsReference [TxIn
headScriptRef]
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [TxOut CtxTx Era] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall era build.
[TxOut CtxTx era]
-> TxBodyContent build era -> TxBodyContent build era
addTxOuts [TxOut CtxTx Era
headOutput']
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [Hash PaymentKey] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall era build.
IsAlonzoBasedEra era =>
[Hash PaymentKey]
-> TxBodyContent build era -> TxBodyContent build era
addTxExtraKeyWits [VerificationKey PaymentKey -> Hash PaymentKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash VerificationKey PaymentKey
vk]
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& TxValidityUpperBound Era
-> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall era build.
TxValidityUpperBound era
-> TxBodyContent build era -> TxBodyContent build era
setTxValidityUpperBound (SlotNo -> TxValidityUpperBound Era
TxValidityUpperBound SlotNo
upperValiditySlot)
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& TxMetadataInEra Era
-> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall era build.
TxMetadataInEra era
-> TxBodyContent build era -> TxBodyContent build era
setTxMetadata (TxMetadata -> TxMetadataInEra Era
TxMetadataInEra (TxMetadata -> TxMetadataInEra Era)
-> TxMetadata -> TxMetadataInEra Era
forall a b. (a -> b) -> a -> b
$ Text -> TxMetadata
mkHydraHeadV1TxName Text
"IncrementTx")
 where
  headRedeemer :: HashableScriptData
headRedeemer =
    Input -> HashableScriptData
forall a. ToScriptData a => a -> HashableScriptData
toScriptData (Input -> HashableScriptData) -> Input -> HashableScriptData
forall a b. (a -> b) -> a -> b
$
      IncrementRedeemer -> Input
Head.Increment
        Head.IncrementRedeemer
          { $sel:signature:IncrementRedeemer :: [Signature]
signature = MultiSignature (Snapshot Tx) -> [Signature]
forall {k} (a :: k). MultiSignature a -> [Signature]
toPlutusSignatures MultiSignature (Snapshot Tx)
sigs
          , $sel:snapshotNumber:IncrementRedeemer :: SnapshotVersion
snapshotNumber = SnapshotNumber -> SnapshotVersion
forall a b. (Integral a, Num b) => a -> b
fromIntegral SnapshotNumber
number
          , $sel:increment:IncrementRedeemer :: TxOutRef
increment = TxIn -> TxOutRef
toPlutusTxOutRef TxIn
depositIn
          }

  HeadParameters{[Party]
parties :: [Party]
$sel:parties:HeadParameters :: HeadParameters -> [Party]
parties, ContestationPeriod
contestationPeriod :: ContestationPeriod
$sel:contestationPeriod:HeadParameters :: HeadParameters -> ContestationPeriod
contestationPeriod} = HeadParameters
headParameters

  headOutput' :: TxOut CtxTx Era
headOutput' =
    TxOut CtxUTxO
headOutput
      TxOut CtxUTxO
-> (TxOut CtxUTxO -> TxOut CtxTx Era) -> TxOut CtxTx Era
forall a b. a -> (a -> b) -> b
& (TxOutDatum CtxUTxO Era -> TxOutDatum CtxTx Era)
-> TxOut CtxUTxO -> TxOut CtxTx Era
forall ctx0 era ctx1.
(TxOutDatum ctx0 era -> TxOutDatum ctx1 era)
-> TxOut ctx0 era -> TxOut ctx1 era
modifyTxOutDatum (TxOutDatum CtxTx Era
-> TxOutDatum CtxUTxO Era -> TxOutDatum CtxTx Era
forall a b. a -> b -> a
const TxOutDatum CtxTx Era
headDatumAfter)
      TxOut CtxTx Era
-> (TxOut CtxTx Era -> TxOut CtxTx Era) -> TxOut CtxTx Era
forall a b. a -> (a -> b) -> b
& (Value -> Value) -> TxOut CtxTx Era -> TxOut CtxTx Era
forall era ctx.
IsMaryBasedEra era =>
(Value -> Value) -> TxOut ctx era -> TxOut ctx era
modifyTxOutValue (Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value
depositedValue)

  headScriptRef :: TxIn
headScriptRef = (TxIn, TxOut CtxUTxO) -> TxIn
forall a b. (a, b) -> a
fst (ScriptRegistry -> (TxIn, TxOut CtxUTxO)
headReference ScriptRegistry
scriptRegistry)

  headWitness :: BuildTxWith BuildTx (Witness WitCtxTxIn)
headWitness =
    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
$
      ScriptWitnessInCtx WitCtxTxIn
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn
forall ctx.
ScriptWitnessInCtx ctx -> ScriptWitness ctx -> Witness ctx
ScriptWitness ScriptWitnessInCtx WitCtxTxIn
forall ctx. IsScriptWitnessInCtx ctx => ScriptWitnessInCtx ctx
scriptWitnessInCtx (ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn)
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn
forall a b. (a -> b) -> a -> b
$
        TxIn
-> PlutusScript PlutusScriptV3
-> ScriptDatum WitCtxTxIn
-> HashableScriptData
-> ScriptWitness WitCtxTxIn
forall ctx era lang.
(IsPlutusScriptLanguage lang, HasScriptLanguageInEra lang era) =>
TxIn
-> PlutusScript lang
-> ScriptDatum ctx
-> HashableScriptData
-> ScriptWitness ctx era
mkScriptReference TxIn
headScriptRef PlutusScript PlutusScriptV3
Head.validatorScript ScriptDatum WitCtxTxIn
InlineScriptDatum HashableScriptData
headRedeemer

  utxoHash :: ToBuiltin ByteString
utxoHash = ByteString -> ToBuiltin ByteString
forall a. HasToBuiltin a => a -> ToBuiltin a
toBuiltin (ByteString -> ToBuiltin ByteString)
-> ByteString -> ToBuiltin ByteString
forall a b. (a -> b) -> a -> b
$ forall tx. IsTx tx => UTxOType tx -> ByteString
hashUTxO @Tx UTxOType Tx
utxo

  headDatumAfter :: TxOutDatum CtxTx Era
headDatumAfter =
    State -> TxOutDatum CtxTx Era
forall era a ctx.
(ToScriptData a, IsBabbageBasedEra era) =>
a -> TxOutDatum ctx era
mkTxOutDatumInline (State -> TxOutDatum CtxTx Era) -> State -> TxOutDatum CtxTx Era
forall a b. (a -> b) -> a -> b
$
      OpenDatum -> State
Head.Open
        Head.OpenDatum
          { $sel:parties:OpenDatum :: [Party]
Head.parties = Party -> Party
partyToChain (Party -> Party) -> [Party] -> [Party]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Party]
parties
          , Signature
ToBuiltin ByteString
utxoHash :: ToBuiltin ByteString
$sel:utxoHash:OpenDatum :: Signature
utxoHash
          , $sel:contestationPeriod:OpenDatum :: ContestationPeriod
contestationPeriod = ContestationPeriod -> ContestationPeriod
toChain ContestationPeriod
contestationPeriod
          , $sel:headId:OpenDatum :: CurrencySymbol
headId = HeadId -> CurrencySymbol
headIdToCurrencySymbol HeadId
headId
          , $sel:version:OpenDatum :: SnapshotVersion
version = SnapshotVersion -> SnapshotVersion
forall a. Integral a => a -> SnapshotVersion
toInteger SnapshotVersion
version SnapshotVersion -> SnapshotVersion -> SnapshotVersion
forall a. Num a => a -> a -> a
+ SnapshotVersion
1
          }

  depositedValue :: Value
depositedValue = ((TxIn, TxOut CtxUTxO) -> Value)
-> [(TxIn, TxOut CtxUTxO)] -> Value
forall m a. Monoid m => (a -> m) -> [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 (TxOut CtxUTxO -> Value)
-> ((TxIn, TxOut CtxUTxO) -> TxOut CtxUTxO)
-> (TxIn, TxOut CtxUTxO)
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn, TxOut CtxUTxO) -> TxOut CtxUTxO
forall a b. (a, b) -> b
snd) ([(TxIn, TxOut CtxUTxO)] -> Value)
-> [(TxIn, TxOut CtxUTxO)] -> Value
forall a b. (a -> b) -> a -> b
$ UTxO' (TxOut CtxUTxO) -> [(TxIn, TxOut CtxUTxO)]
forall out. UTxO' out -> [(TxIn, out)]
UTxO.pairs (UTxO' (TxOut CtxUTxO)
-> Maybe (UTxO' (TxOut CtxUTxO)) -> UTxO' (TxOut CtxUTxO)
forall a. a -> Maybe a -> a
fromMaybe UTxO' (TxOut CtxUTxO)
forall a. Monoid a => a
mempty Maybe (UTxO' (TxOut CtxUTxO))
Maybe (UTxOType Tx)
utxoToCommit)

  -- NOTE: we expect always a single output from a deposit tx
  (TxIn
depositIn, TxOut CtxUTxO
_) = [(TxIn, TxOut CtxUTxO)] -> (TxIn, TxOut CtxUTxO)
forall a. HasCallStack => [a] -> a
List.head ([(TxIn, TxOut CtxUTxO)] -> (TxIn, TxOut CtxUTxO))
-> [(TxIn, TxOut CtxUTxO)] -> (TxIn, TxOut CtxUTxO)
forall a b. (a -> b) -> a -> b
$ UTxO' (TxOut CtxUTxO) -> [(TxIn, TxOut CtxUTxO)]
forall out. UTxO' out -> [(TxIn, out)]
UTxO.pairs UTxO' (TxOut CtxUTxO)
depositScriptUTxO

  depositRedeemer :: HashableScriptData
depositRedeemer = Redeemer -> HashableScriptData
forall a. ToScriptData a => a -> HashableScriptData
toScriptData (Redeemer -> HashableScriptData) -> Redeemer -> HashableScriptData
forall a b. (a -> b) -> a -> b
$ DepositRedeemer -> Redeemer
Deposit.redeemer (DepositRedeemer -> Redeemer) -> DepositRedeemer -> Redeemer
forall a b. (a -> b) -> a -> b
$ CurrencySymbol -> DepositRedeemer
Deposit.Claim (CurrencySymbol -> DepositRedeemer)
-> CurrencySymbol -> DepositRedeemer
forall a b. (a -> b) -> a -> b
$ HeadId -> CurrencySymbol
headIdToCurrencySymbol HeadId
headId

  depositWitness :: BuildTxWith BuildTx (Witness WitCtxTxIn)
depositWitness =
    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
$
      ScriptWitnessInCtx WitCtxTxIn
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn
forall ctx.
ScriptWitnessInCtx ctx -> ScriptWitness ctx -> Witness ctx
ScriptWitness ScriptWitnessInCtx WitCtxTxIn
forall ctx. IsScriptWitnessInCtx ctx => ScriptWitnessInCtx ctx
scriptWitnessInCtx (ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn)
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn
forall a b. (a -> b) -> a -> b
$
        PlutusScript PlutusScriptV3
-> ScriptDatum WitCtxTxIn
-> HashableScriptData
-> ScriptWitness WitCtxTxIn
forall ctx era lang.
(IsPlutusScriptLanguage lang, HasScriptLanguageInEra lang era) =>
PlutusScript lang
-> ScriptDatum ctx -> HashableScriptData -> ScriptWitness ctx era
mkScriptWitness PlutusScript PlutusScriptV3
depositValidatorScript ScriptDatum WitCtxTxIn
InlineScriptDatum HashableScriptData
depositRedeemer

  Snapshot{UTxOType Tx
utxo :: UTxOType Tx
$sel:utxo:Snapshot :: forall tx. Snapshot tx -> UTxOType tx
utxo, Maybe (UTxOType Tx)
utxoToCommit :: Maybe (UTxOType Tx)
$sel:utxoToCommit:Snapshot :: forall tx. Snapshot tx -> Maybe (UTxOType tx)
utxoToCommit, SnapshotVersion
version :: SnapshotVersion
$sel:version:Snapshot :: forall tx. Snapshot tx -> SnapshotVersion
version, SnapshotNumber
number :: SnapshotNumber
$sel:number:Snapshot :: forall tx. Snapshot tx -> SnapshotNumber
number} = Snapshot Tx
snapshot