module Hydra.Tx.Recover 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,
  setValidityLowerBound,
  unsafeBuildTransaction,
 )
import Hydra.Tx (HeadId, mkHeadId)
import Hydra.Tx.Utils (mkHydraHeadV1TxName)

-- | Builds a recover transaction to recover locked funds from the v_deposit script.
recoverTx ::
  -- | Deposit input
  TxId ->
  -- | Deposited UTxO to recover
  UTxO ->
  -- | Lower bound slot number
  SlotNo ->
  Tx
recoverTx :: TxId -> UTxO -> SlotNo -> Tx
recoverTx TxId
depositTxId UTxO
deposited SlotNo
lowerBoundSlot =
  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
recoverInputs
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [TxOut CtxTx Era] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addOutputs [TxOut CtxTx Era]
depositOutputs
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& SlotNo -> TxBodyContent BuildTx -> TxBodyContent BuildTx
setValidityLowerBound SlotNo
lowerBoundSlot
      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
"RecoverTx")
 where
  recoverInputs :: TxIns BuildTx
recoverInputs = (,BuildTxWith BuildTx (Witness WitCtxTxIn)
depositWitness) (TxIn -> (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn)))
-> [TxIn] -> TxIns BuildTx
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TxId -> TxIx -> TxIn
TxIn TxId
depositTxId (Word -> TxIx
TxIx Word
0)]

  redeemer :: HashableScriptData
redeemer = DepositRedeemer -> HashableScriptData
forall a. ToScriptData a => a -> HashableScriptData
toScriptData (DepositRedeemer -> HashableScriptData)
-> DepositRedeemer -> HashableScriptData
forall a b. (a -> b) -> a -> b
$ Integer -> DepositRedeemer
Deposit.Recover (Integer -> DepositRedeemer) -> Integer -> DepositRedeemer
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ [TxOut CtxTx Era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TxOut CtxTx Era]
depositOutputs

  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
depositScript ScriptDatum WitCtxTxIn
InlineScriptDatum HashableScriptData
redeemer

  depositOutputs :: [TxOut CtxTx Era]
depositOutputs =
    TxOut CtxUTxO Era -> 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 Era -> TxOut CtxTx Era)
-> [TxOut CtxUTxO Era] -> [TxOut CtxTx Era]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO -> [TxOut CtxUTxO Era]
forall a. UTxO' a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList UTxO
deposited

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

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

observeRecoverTx ::
  NetworkId ->
  UTxO ->
  Tx ->
  Maybe RecoverObservation
observeRecoverTx :: NetworkId -> UTxO -> Tx -> Maybe RecoverObservation
observeRecoverTx NetworkId
networkId UTxO
utxo Tx
tx = do
  let inputUTxO :: UTxO
inputUTxO = UTxO -> Tx -> UTxO
resolveInputsUTxO UTxO
utxo Tx
tx
  (TxIn TxId
depositTxId TxIx
_, TxOut CtxUTxO Era
depositOut) <- forall lang.
IsPlutusScriptLanguage lang =>
UTxO -> PlutusScript lang -> Maybe (TxIn, TxOut CtxUTxO Era)
findTxOutByScript @PlutusScriptV3 UTxO
inputUTxO PlutusScript PlutusScriptV3
forall {lang}. PlutusScript lang
depositScript
  HashableScriptData
dat <- 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 Era -> 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 Era
depositOut
  Deposit.DepositDatum (CurrencySymbol
headCurrencySymbol, POSIXTime
_, [Commit]
onChainDeposits) <- HashableScriptData -> Maybe DepositDatum
forall a. FromScriptData a => HashableScriptData -> Maybe a
fromScriptData HashableScriptData
dat
  UTxO
deposits <- do
    [(TxIn, TxOut CtxUTxO Era)]
depositedUTxO <- (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 (Network -> Commit -> Maybe (TxIn, TxOut CtxUTxO Era)
Commit.deserializeCommit (NetworkId -> Network
networkIdToNetwork NetworkId
networkId)) [Commit]
onChainDeposits
    UTxO -> Maybe UTxO
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTxO -> Maybe UTxO) -> UTxO -> Maybe UTxO
forall a b. (a -> b) -> a -> b
$ [(TxIn, TxOut CtxUTxO Era)] -> UTxO
forall out. [(TxIn, out)] -> UTxO' out
UTxO.fromPairs [(TxIn, TxOut CtxUTxO Era)]
depositedUTxO
  HeadId
headId <- (PolicyId -> HeadId) -> Maybe PolicyId -> Maybe HeadId
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PolicyId -> HeadId
mkHeadId (Maybe PolicyId -> Maybe HeadId)
-> (CurrencySymbol -> Maybe PolicyId)
-> CurrencySymbol
-> Maybe HeadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CurrencySymbol -> Maybe PolicyId
forall (m :: * -> *). MonadFail m => CurrencySymbol -> m PolicyId
fromPlutusCurrencySymbol (CurrencySymbol -> Maybe HeadId) -> CurrencySymbol -> Maybe HeadId
forall a b. (a -> b) -> a -> b
$ CurrencySymbol
headCurrencySymbol
  let depositOuts :: [TxOut CtxTx Era]
depositOuts = TxOut CtxUTxO Era -> 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 Era -> TxOut CtxTx Era)
-> ((TxIn, TxOut CtxUTxO Era) -> TxOut CtxUTxO Era)
-> (TxIn, TxOut CtxUTxO Era)
-> TxOut CtxTx Era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn, TxOut CtxUTxO Era) -> TxOut CtxUTxO Era
forall a b. (a, b) -> b
snd ((TxIn, TxOut CtxUTxO Era) -> TxOut CtxTx Era)
-> [(TxIn, TxOut CtxUTxO Era)] -> [TxOut CtxTx Era]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO -> [(TxIn, TxOut CtxUTxO Era)]
forall out. UTxO' out -> [(TxIn, out)]
UTxO.pairs UTxO
deposits
  -- NOTE: All deposit outputs need to be present in the recover tx outputs but
  -- the two lists of outputs are not necesarilly the same.
  if (TxOut CtxTx Era -> Bool) -> [TxOut CtxTx Era] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TxOut CtxTx Era -> [TxOut CtxTx Era] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` Tx -> [TxOut CtxTx Era]
forall era. Tx era -> [TxOut CtxTx era]
txOuts' Tx
tx) [TxOut CtxTx Era]
depositOuts
    then
      RecoverObservation -> Maybe RecoverObservation
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ( RecoverObservation
            { HeadId
$sel:headId:RecoverObservation :: HeadId
headId :: HeadId
headId
            , $sel:recoveredTxId:RecoverObservation :: TxId
recoveredTxId = TxId
depositTxId
            }
        )
    else Maybe RecoverObservation
forall a. Maybe a
Nothing
 where
  depositScript :: PlutusScript lang
depositScript = SerialisedScript -> PlutusScript lang
forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript SerialisedScript
Deposit.validatorScript