module Hydra.Tx.Decrement where

import Hydra.Cardano.Api
import Hydra.Prelude

import Hydra.Contract.Head qualified as Head
import Hydra.Contract.HeadState qualified as Head
import Hydra.Ledger.Cardano.Builder (
  unsafeBuildTransaction,
 )
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 (..), SnapshotVersion, fromChainSnapshotVersion)
import Hydra.Tx.Utils (findStateToken, mkHydraHeadV1TxName)
import PlutusLedgerApi.V3 (toBuiltin)

-- * Construction

-- | Construct a _decrement_ transaction which takes as input some 'UTxO' present
-- in the L2 ledger state and makes it available on L1.
decrementTx ::
  -- | 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 ->
  MultiSignature (Snapshot Tx) ->
  Tx
decrementTx :: ScriptRegistry
-> VerificationKey PaymentKey
-> HeadId
-> HeadParameters
-> (TxIn, TxOut CtxUTxO)
-> Snapshot Tx
-> MultiSignature (Snapshot Tx)
-> Tx
decrementTx ScriptRegistry
scriptRegistry VerificationKey PaymentKey
vk HeadId
headId HeadParameters
headParameters (TxIn
headInput, TxOut CtxUTxO
headOutput) Snapshot Tx
snapshot MultiSignature (Snapshot Tx)
signatures =
  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)]
      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' TxOut CtxTx Era -> [TxOut CtxTx Era] -> [TxOut CtxTx Era]
forall a. a -> [a] -> [a]
: (TxOut CtxUTxO -> TxOut CtxTx Era)
-> [TxOut CtxUTxO] -> [TxOut CtxTx Era]
forall a b. (a -> b) -> [a] -> [b]
map TxOut CtxUTxO -> TxOut CtxTx Era
forall era. TxOut CtxUTxO era -> TxOut CtxTx era
forall {k} (f :: * -> k -> *) (era :: k).
ToTxContext f =>
f CtxUTxO era -> f CtxTx era
toTxContext [TxOut CtxUTxO]
decommitOutputs)
      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
& 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
"DecrementTx")
 where
  headRedeemer :: HashableScriptData
headRedeemer =
    Input -> HashableScriptData
forall a. ToScriptData a => a -> HashableScriptData
toScriptData (Input -> HashableScriptData) -> Input -> HashableScriptData
forall a b. (a -> b) -> a -> b
$
      DecrementRedeemer -> Input
Head.Decrement
        Head.DecrementRedeemer
          { $sel:signature:DecrementRedeemer :: [Signature]
signature = MultiSignature (Snapshot Tx) -> [Signature]
forall {k} (a :: k). MultiSignature a -> [Signature]
toPlutusSignatures MultiSignature (Snapshot Tx)
signatures
          , $sel:snapshotNumber:DecrementRedeemer :: Integer
snapshotNumber = SnapshotNumber -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral SnapshotNumber
number
          , $sel:numberOfDecommitOutputs:DecrementRedeemer :: Integer
numberOfDecommitOutputs =
              Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ [TxOut CtxUTxO] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([TxOut CtxUTxO] -> Int) -> [TxOut CtxUTxO] -> Int
forall a b. (a -> b) -> a -> b
$ [TxOut CtxUTxO]
-> (UTxO' (TxOut CtxUTxO) -> [TxOut CtxUTxO])
-> Maybe (UTxO' (TxOut CtxUTxO))
-> [TxOut CtxUTxO]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] UTxO' (TxOut CtxUTxO) -> [TxOut CtxUTxO]
forall a. UTxO' a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Maybe (UTxO' (TxOut CtxUTxO))
Maybe (UTxOType Tx)
utxoToDecommit
          }

  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

  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
v -> Value
v Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value -> Value
negateValue Value
decomittedValue)

  decomittedValue :: Value
decomittedValue = (TxOut CtxUTxO -> Value) -> [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]
decommitOutputs

  decommitOutputs :: [TxOut CtxUTxO]
decommitOutputs = [TxOut CtxUTxO]
-> (UTxO' (TxOut CtxUTxO) -> [TxOut CtxUTxO])
-> Maybe (UTxO' (TxOut CtxUTxO))
-> [TxOut CtxUTxO]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] UTxO' (TxOut CtxUTxO) -> [TxOut CtxUTxO]
forall a. UTxO' a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Maybe (UTxO' (TxOut CtxUTxO))
Maybe (UTxOType Tx)
utxoToDecommit

  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

  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 :: Integer
version = SnapshotVersion -> Integer
forall a. Integral a => a -> Integer
toInteger SnapshotVersion
version Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1
          }

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

-- * Observation

data DecrementObservation = DecrementObservation
  { DecrementObservation -> HeadId
headId :: HeadId
  , DecrementObservation -> SnapshotVersion
newVersion :: SnapshotVersion
  , DecrementObservation -> [TxOut CtxUTxO]
distributedOutputs :: [TxOut CtxUTxO]
  }
  deriving stock (Int -> DecrementObservation -> ShowS
[DecrementObservation] -> ShowS
DecrementObservation -> String
(Int -> DecrementObservation -> ShowS)
-> (DecrementObservation -> String)
-> ([DecrementObservation] -> ShowS)
-> Show DecrementObservation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DecrementObservation -> ShowS
showsPrec :: Int -> DecrementObservation -> ShowS
$cshow :: DecrementObservation -> String
show :: DecrementObservation -> String
$cshowList :: [DecrementObservation] -> ShowS
showList :: [DecrementObservation] -> ShowS
Show, DecrementObservation -> DecrementObservation -> Bool
(DecrementObservation -> DecrementObservation -> Bool)
-> (DecrementObservation -> DecrementObservation -> Bool)
-> Eq DecrementObservation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DecrementObservation -> DecrementObservation -> Bool
== :: DecrementObservation -> DecrementObservation -> Bool
$c/= :: DecrementObservation -> DecrementObservation -> Bool
/= :: DecrementObservation -> DecrementObservation -> Bool
Eq, (forall x. DecrementObservation -> Rep DecrementObservation x)
-> (forall x. Rep DecrementObservation x -> DecrementObservation)
-> Generic DecrementObservation
forall x. Rep DecrementObservation x -> DecrementObservation
forall x. DecrementObservation -> Rep DecrementObservation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. DecrementObservation -> Rep DecrementObservation x
from :: forall x. DecrementObservation -> Rep DecrementObservation x
$cto :: forall x. Rep DecrementObservation x -> DecrementObservation
to :: forall x. Rep DecrementObservation x -> DecrementObservation
Generic)

observeDecrementTx ::
  UTxO ->
  Tx ->
  Maybe DecrementObservation
observeDecrementTx :: UTxO' (TxOut CtxUTxO) -> Tx -> Maybe DecrementObservation
observeDecrementTx UTxO' (TxOut CtxUTxO)
utxo Tx
tx = do
  let inputUTxO :: UTxO' (TxOut CtxUTxO)
inputUTxO = UTxO' (TxOut CtxUTxO) -> Tx -> UTxO' (TxOut CtxUTxO)
resolveInputsUTxO UTxO' (TxOut CtxUTxO)
utxo Tx
tx
  (TxIn
headInput, TxOut CtxUTxO
headOutput) <- UTxO' (TxOut CtxUTxO)
-> PlutusScript PlutusScriptV3 -> Maybe (TxIn, TxOut CtxUTxO)
forall lang.
IsPlutusScriptLanguage lang =>
UTxO' (TxOut CtxUTxO)
-> PlutusScript lang -> Maybe (TxIn, TxOut CtxUTxO)
findTxOutByScript UTxO' (TxOut CtxUTxO)
inputUTxO PlutusScript PlutusScriptV3
Head.validatorScript
  Input
redeemer <- Tx -> TxIn -> Maybe Input
forall a. FromData a => Tx -> TxIn -> Maybe a
findRedeemerSpending Tx
tx TxIn
headInput
  HashableScriptData
oldHeadDatum <- TxOut CtxTx Era -> Maybe HashableScriptData
forall era. TxOut CtxTx era -> Maybe HashableScriptData
txOutScriptData (TxOut CtxTx Era -> Maybe HashableScriptData)
-> TxOut CtxTx Era -> Maybe HashableScriptData
forall a b. (a -> b) -> a -> b
$ TxOut CtxUTxO -> TxOut CtxTx Era
forall era. TxOut CtxUTxO era -> TxOut CtxTx era
forall {k} (f :: * -> k -> *) (era :: k).
ToTxContext f =>
f CtxUTxO era -> f CtxTx era
toTxContext TxOut CtxUTxO
headOutput
  State
datum <- HashableScriptData -> Maybe State
forall a. FromScriptData a => HashableScriptData -> Maybe a
fromScriptData HashableScriptData
oldHeadDatum
  HeadId
headId <- TxOut CtxUTxO -> Maybe HeadId
forall ctx. TxOut ctx -> Maybe HeadId
findStateToken TxOut CtxUTxO
headOutput
  case (State
datum, Input
redeemer) of
    (Head.Open{}, Head.Decrement Head.DecrementRedeemer{Integer
$sel:numberOfDecommitOutputs:DecrementRedeemer :: DecrementRedeemer -> Integer
numberOfDecommitOutputs :: Integer
numberOfDecommitOutputs}) -> do
      (TxIn
_, TxOut CtxUTxO
newHeadOutput) <- UTxO' (TxOut CtxUTxO)
-> PlutusScript PlutusScriptV3 -> Maybe (TxIn, TxOut CtxUTxO)
forall lang.
IsPlutusScriptLanguage lang =>
UTxO' (TxOut CtxUTxO)
-> PlutusScript lang -> Maybe (TxIn, TxOut CtxUTxO)
findTxOutByScript (Tx -> UTxO' (TxOut CtxUTxO)
utxoFromTx Tx
tx) PlutusScript PlutusScriptV3
Head.validatorScript
      HashableScriptData
newHeadDatum <- TxOut CtxTx Era -> Maybe HashableScriptData
forall era. TxOut CtxTx era -> Maybe HashableScriptData
txOutScriptData (TxOut CtxTx Era -> Maybe HashableScriptData)
-> TxOut CtxTx Era -> Maybe HashableScriptData
forall a b. (a -> b) -> a -> b
$ TxOut CtxUTxO -> TxOut CtxTx Era
forall era. TxOut CtxUTxO era -> TxOut CtxTx era
forall {k} (f :: * -> k -> *) (era :: k).
ToTxContext f =>
f CtxUTxO era -> f CtxTx era
toTxContext TxOut CtxUTxO
newHeadOutput
      case HashableScriptData -> Maybe State
forall a. FromScriptData a => HashableScriptData -> Maybe a
fromScriptData HashableScriptData
newHeadDatum of
        Just (Head.Open Head.OpenDatum{Integer
$sel:version:OpenDatum :: OpenDatum -> Integer
version :: Integer
version}) ->
          DecrementObservation -> Maybe DecrementObservation
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            DecrementObservation
              { HeadId
$sel:headId:DecrementObservation :: HeadId
headId :: HeadId
headId
              , $sel:newVersion:DecrementObservation :: SnapshotVersion
newVersion = Integer -> SnapshotVersion
fromChainSnapshotVersion Integer
version
              , $sel:distributedOutputs:DecrementObservation :: [TxOut CtxUTxO]
distributedOutputs =
                  TxOut CtxTx Era -> TxOut CtxUTxO
forall era. TxOut CtxTx era -> TxOut CtxUTxO era
toCtxUTxOTxOut (TxOut CtxTx Era -> TxOut CtxUTxO)
-> [TxOut CtxTx Era] -> [TxOut CtxUTxO]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tx -> [TxOut CtxTx Era]
forall era. Tx era -> [TxOut CtxTx era]
txOuts' Tx
tx
                    [TxOut CtxUTxO]
-> ([TxOut CtxUTxO] -> [TxOut CtxUTxO]) -> [TxOut CtxUTxO]
forall a b. a -> (a -> b) -> b
& Int -> [TxOut CtxUTxO] -> [TxOut CtxUTxO]
forall a. Int -> [a] -> [a]
drop Int
1 -- NOTE: Head output must be in first position
                    [TxOut CtxUTxO]
-> ([TxOut CtxUTxO] -> [TxOut CtxUTxO]) -> [TxOut CtxUTxO]
forall a b. a -> (a -> b) -> b
& Int -> [TxOut CtxUTxO] -> [TxOut CtxUTxO]
forall a. Int -> [a] -> [a]
take (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
numberOfDecommitOutputs)
              }
        Maybe State
_ -> Maybe DecrementObservation
forall a. Maybe a
Nothing
    (State, Input)
_ -> Maybe DecrementObservation
forall a. Maybe a
Nothing