module Hydra.Tx.Abort where

import Hydra.Cardano.Api
import Hydra.Prelude

import Cardano.Api.UTxO qualified as UTxO
import Data.Map qualified as Map
import Hydra.Contract.Commit qualified as Commit
import Hydra.Contract.Head qualified as Head
import Hydra.Contract.HeadState qualified as Head
import Hydra.Contract.Initial qualified as Initial
import Hydra.Contract.MintAction (MintAction (Burn))
import Hydra.Ledger.Cardano.Builder (
  addExtraRequiredSigners,
  addInputs,
  addOutputs,
  addReferenceInputs,
  burnTokens,
  emptyTxBody,
  unsafeBuildTransaction,
 )
import Hydra.Plutus (commitValidatorScript, initialValidatorScript)
import Hydra.Tx (ScriptRegistry (..))
import Hydra.Tx.Utils (headTokensFromValue)

data AbortTxError
  = OverlappingInputs
  | CannotFindHeadOutputToAbort
  deriving stock (Int -> AbortTxError -> ShowS
[AbortTxError] -> ShowS
AbortTxError -> String
(Int -> AbortTxError -> ShowS)
-> (AbortTxError -> String)
-> ([AbortTxError] -> ShowS)
-> Show AbortTxError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AbortTxError -> ShowS
showsPrec :: Int -> AbortTxError -> ShowS
$cshow :: AbortTxError -> String
show :: AbortTxError -> String
$cshowList :: [AbortTxError] -> ShowS
showList :: [AbortTxError] -> ShowS
Show)

-- | Create transaction which aborts a head by spending the Head output and all
-- other "initial" outputs.
abortTx ::
  -- | Committed UTxOs to reimburse.
  UTxO ->
  -- | Published Hydra scripts to reference.
  ScriptRegistry ->
  -- | Party who's authorizing this transaction
  VerificationKey PaymentKey ->
  -- | Everything needed to spend the Head state-machine output.
  (TxIn, TxOut CtxUTxO) ->
  -- | Script for monetary policy to burn tokens
  PlutusScript ->
  -- | Data needed to spend the initial output sent to each party to the Head.
  -- Should contain the PT and is locked by initial script.
  Map TxIn (TxOut CtxUTxO) ->
  -- | Data needed to spend commit outputs.
  -- Should contain the PT and is locked by commit script.
  Map TxIn (TxOut CtxUTxO) ->
  Either AbortTxError Tx
abortTx :: UTxO
-> ScriptRegistry
-> VerificationKey PaymentKey
-> (TxIn, TxOut CtxUTxO)
-> PlutusScript
-> Map TxIn (TxOut CtxUTxO)
-> Map TxIn (TxOut CtxUTxO)
-> Either AbortTxError Tx
abortTx UTxO
committedUTxO ScriptRegistry
scriptRegistry VerificationKey PaymentKey
vk (TxIn
headInput, TxOut CtxUTxO
initialHeadOutput) PlutusScript
headTokenScript Map TxIn (TxOut CtxUTxO)
initialsToAbort Map TxIn (TxOut CtxUTxO)
commitsToAbort
  | Maybe (TxOut CtxUTxO) -> Bool
forall a. Maybe a -> Bool
isJust (Key (Map TxIn (TxOut CtxUTxO))
-> Map TxIn (TxOut CtxUTxO)
-> Maybe (Val (Map TxIn (TxOut CtxUTxO)))
forall t. StaticMap t => Key t -> t -> Maybe (Val t)
lookup TxIn
Key (Map TxIn (TxOut CtxUTxO))
headInput Map TxIn (TxOut CtxUTxO)
initialsToAbort) =
      AbortTxError -> Either AbortTxError Tx
forall a b. a -> Either a b
Left AbortTxError
OverlappingInputs
  | Bool
otherwise =
      Tx -> Either AbortTxError Tx
forall a b. b -> Either a b
Right (Tx -> Either AbortTxError Tx) -> Tx -> Either AbortTxError Tx
forall a b. (a -> b) -> a -> b
$
        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
& [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))]
-> TxBodyContent BuildTx -> TxBodyContent BuildTx
addInputs ((TxIn
headInput, BuildTxWith BuildTx (Witness WitCtxTxIn Era)
headWitness) (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))
-> [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))]
-> [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))]
forall a. a -> [a] -> [a]
: [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))]
initialInputs [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))]
-> [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))]
-> [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))]
forall a. Semigroup a => a -> a -> a
<> [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))]
commitInputs)
            TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [TxIn] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addReferenceInputs ([TxIn
headScriptRef, TxIn
initialScriptRef] [TxIn] -> [TxIn] -> [TxIn]
forall a. Semigroup a => a -> a -> a
<> [TxIn
commitScriptRef | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))]
commitInputs])
            TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [TxOut CtxTx] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addOutputs [TxOut CtxTx]
reimbursedOutputs
            TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& PlutusScript
-> MintAction
-> [(AssetName, Quantity)]
-> TxBodyContent BuildTx
-> TxBodyContent BuildTx
forall redeemer.
ToScriptData redeemer =>
PlutusScript
-> redeemer
-> [(AssetName, Quantity)]
-> TxBodyContent BuildTx
-> TxBodyContent BuildTx
burnTokens PlutusScript
headTokenScript MintAction
Burn [(AssetName, Quantity)]
headTokens
            TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [Hash PaymentKey] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addExtraRequiredSigners [VerificationKey PaymentKey -> Hash PaymentKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash VerificationKey PaymentKey
vk]
 where
  headWitness :: BuildTxWith BuildTx (Witness WitCtxTxIn Era)
headWitness =
    Witness WitCtxTxIn Era
-> BuildTxWith BuildTx (Witness WitCtxTxIn Era)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Witness WitCtxTxIn Era
 -> BuildTxWith BuildTx (Witness WitCtxTxIn Era))
-> Witness WitCtxTxIn Era
-> BuildTxWith BuildTx (Witness WitCtxTxIn Era)
forall a b. (a -> b) -> a -> b
$
      ScriptWitnessInCtx WitCtxTxIn
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn Era
forall ctx.
ScriptWitnessInCtx ctx -> ScriptWitness ctx -> Witness ctx
ScriptWitness ScriptWitnessInCtx WitCtxTxIn
forall ctx. IsScriptWitnessInCtx ctx => ScriptWitnessInCtx ctx
scriptWitnessInCtx (ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn Era)
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn Era
forall a b. (a -> b) -> a -> b
$
        TxIn
-> PlutusScript
-> ScriptDatum WitCtxTxIn
-> ScriptRedeemer
-> ScriptWitness WitCtxTxIn
forall ctx era lang.
(IsPlutusScriptLanguage lang, HasScriptLanguageInEra lang era) =>
TxIn
-> PlutusScript lang
-> ScriptDatum ctx
-> ScriptRedeemer
-> ScriptWitness ctx era
mkScriptReference TxIn
headScriptRef PlutusScript
headScript ScriptDatum WitCtxTxIn
InlineScriptDatum ScriptRedeemer
headRedeemer
  headScriptRef :: TxIn
headScriptRef =
    (TxIn, TxOut CtxUTxO) -> TxIn
forall a b. (a, b) -> a
fst (ScriptRegistry -> (TxIn, TxOut CtxUTxO)
headReference ScriptRegistry
scriptRegistry)
  headScript :: PlutusScript
headScript =
    forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV3 SerialisedScript
Head.validatorScript
  headRedeemer :: ScriptRedeemer
headRedeemer =
    Input -> ScriptRedeemer
forall a. ToScriptData a => a -> ScriptRedeemer
toScriptData Input
Head.Abort

  initialInputs :: [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))]
initialInputs = TxIn -> (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))
mkAbortInitial (TxIn -> (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era)))
-> [TxIn] -> [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map TxIn (TxOut CtxUTxO) -> [TxIn]
forall k a. Map k a -> [k]
Map.keys Map TxIn (TxOut CtxUTxO)
initialsToAbort

  commitInputs :: [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))]
commitInputs = TxIn -> (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))
mkAbortCommit (TxIn -> (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era)))
-> [TxIn] -> [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map TxIn (TxOut CtxUTxO) -> [TxIn]
forall k a. Map k a -> [k]
Map.keys Map TxIn (TxOut CtxUTxO)
commitsToAbort

  headTokens :: [(AssetName, Quantity)]
headTokens =
    PlutusScript -> Value -> [(AssetName, Quantity)]
headTokensFromValue PlutusScript
headTokenScript (Value -> [(AssetName, Quantity)])
-> Value -> [(AssetName, Quantity)]
forall a b. (a -> b) -> a -> b
$
      [Value] -> Value
forall a. Monoid a => [a] -> a
mconcat
        [ TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO
initialHeadOutput
        , (TxOut CtxUTxO -> Value) -> Map TxIn (TxOut CtxUTxO) -> Value
forall m a. Monoid m => (a -> m) -> Map TxIn 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 Map TxIn (TxOut CtxUTxO)
initialsToAbort
        , (TxOut CtxUTxO -> Value) -> Map TxIn (TxOut CtxUTxO) -> Value
forall m a. Monoid m => (a -> m) -> Map TxIn 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 Map TxIn (TxOut CtxUTxO)
commitsToAbort
        ]

  mkAbortInitial :: TxIn -> (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))
mkAbortInitial TxIn
initialInput = (TxIn
initialInput, BuildTxWith BuildTx (Witness WitCtxTxIn Era)
abortInitialWitness)
  abortInitialWitness :: BuildTxWith BuildTx (Witness WitCtxTxIn Era)
abortInitialWitness =
    Witness WitCtxTxIn Era
-> BuildTxWith BuildTx (Witness WitCtxTxIn Era)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Witness WitCtxTxIn Era
 -> BuildTxWith BuildTx (Witness WitCtxTxIn Era))
-> Witness WitCtxTxIn Era
-> BuildTxWith BuildTx (Witness WitCtxTxIn Era)
forall a b. (a -> b) -> a -> b
$
      ScriptWitnessInCtx WitCtxTxIn
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn Era
forall ctx.
ScriptWitnessInCtx ctx -> ScriptWitness ctx -> Witness ctx
ScriptWitness ScriptWitnessInCtx WitCtxTxIn
forall ctx. IsScriptWitnessInCtx ctx => ScriptWitnessInCtx ctx
scriptWitnessInCtx (ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn Era)
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn Era
forall a b. (a -> b) -> a -> b
$
        TxIn
-> PlutusScript
-> ScriptDatum WitCtxTxIn
-> ScriptRedeemer
-> ScriptWitness WitCtxTxIn
forall ctx era lang.
(IsPlutusScriptLanguage lang, HasScriptLanguageInEra lang era) =>
TxIn
-> PlutusScript lang
-> ScriptDatum ctx
-> ScriptRedeemer
-> ScriptWitness ctx era
mkScriptReference TxIn
initialScriptRef PlutusScript
initialScript ScriptDatum WitCtxTxIn
InlineScriptDatum ScriptRedeemer
initialRedeemer
  initialScriptRef :: TxIn
initialScriptRef =
    (TxIn, TxOut CtxUTxO) -> TxIn
forall a b. (a, b) -> a
fst (ScriptRegistry -> (TxIn, TxOut CtxUTxO)
initialReference ScriptRegistry
scriptRegistry)
  initialScript :: PlutusScript
initialScript =
    forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV3 SerialisedScript
initialValidatorScript
  initialRedeemer :: ScriptRedeemer
initialRedeemer =
    Redeemer -> ScriptRedeemer
forall a. ToScriptData a => a -> ScriptRedeemer
toScriptData (Redeemer -> ScriptRedeemer) -> Redeemer -> ScriptRedeemer
forall a b. (a -> b) -> a -> b
$ RedeemerType -> Redeemer
Initial.redeemer RedeemerType
Initial.ViaAbort

  mkAbortCommit :: TxIn -> (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))
mkAbortCommit TxIn
commitInput = (TxIn
commitInput, BuildTxWith BuildTx (Witness WitCtxTxIn Era)
abortCommitWitness)
  abortCommitWitness :: BuildTxWith BuildTx (Witness WitCtxTxIn Era)
abortCommitWitness =
    Witness WitCtxTxIn Era
-> BuildTxWith BuildTx (Witness WitCtxTxIn Era)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Witness WitCtxTxIn Era
 -> BuildTxWith BuildTx (Witness WitCtxTxIn Era))
-> Witness WitCtxTxIn Era
-> BuildTxWith BuildTx (Witness WitCtxTxIn Era)
forall a b. (a -> b) -> a -> b
$
      ScriptWitnessInCtx WitCtxTxIn
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn Era
forall ctx.
ScriptWitnessInCtx ctx -> ScriptWitness ctx -> Witness ctx
ScriptWitness ScriptWitnessInCtx WitCtxTxIn
forall ctx. IsScriptWitnessInCtx ctx => ScriptWitnessInCtx ctx
scriptWitnessInCtx (ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn Era)
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn Era
forall a b. (a -> b) -> a -> b
$
        TxIn
-> PlutusScript
-> ScriptDatum WitCtxTxIn
-> ScriptRedeemer
-> ScriptWitness WitCtxTxIn
forall ctx era lang.
(IsPlutusScriptLanguage lang, HasScriptLanguageInEra lang era) =>
TxIn
-> PlutusScript lang
-> ScriptDatum ctx
-> ScriptRedeemer
-> ScriptWitness ctx era
mkScriptReference TxIn
commitScriptRef PlutusScript
commitScript ScriptDatum WitCtxTxIn
InlineScriptDatum ScriptRedeemer
commitRedeemer
  commitScriptRef :: TxIn
commitScriptRef =
    (TxIn, TxOut CtxUTxO) -> TxIn
forall a b. (a, b) -> a
fst (ScriptRegistry -> (TxIn, TxOut CtxUTxO)
commitReference ScriptRegistry
scriptRegistry)
  commitScript :: PlutusScript
commitScript =
    forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV3 SerialisedScript
commitValidatorScript
  commitRedeemer :: ScriptRedeemer
commitRedeemer =
    Redeemer -> ScriptRedeemer
forall a. ToScriptData a => a -> ScriptRedeemer
toScriptData (RedeemerType -> Redeemer
Commit.redeemer RedeemerType
Commit.ViaAbort)

  reimbursedOutputs :: [TxOut CtxTx]
reimbursedOutputs = TxOut CtxUTxO -> TxOut CtxTx
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 -> TxOut CtxTx)
-> ((TxIn, TxOut CtxUTxO) -> TxOut CtxUTxO)
-> (TxIn, TxOut CtxUTxO)
-> TxOut CtxTx
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) -> TxOut CtxTx)
-> [(TxIn, TxOut CtxUTxO)] -> [TxOut CtxTx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO -> [(TxIn, TxOut CtxUTxO)]
forall out. UTxO' out -> [(TxIn, out)]
UTxO.pairs UTxO
committedUTxO