module Hydra.Tx.Utils (
  module Hydra.Tx.Utils,
  dummyValidatorScript,
) where

import Hydra.Cardano.Api
import Hydra.Prelude hiding (toList)

import Cardano.Api.UTxO qualified as UTxO
import Cardano.Ledger.Alonzo.Tx qualified as Ledger
import Cardano.Ledger.Api (AlonzoTxAuxData (..), auxDataHashTxBodyL, auxDataTxL, bodyTxL, hashTxAuxData)
import Control.Lens ((.~), (^.))
import Data.Map.Strict qualified as Map
import Data.Maybe.Strict (StrictMaybe (..))
import GHC.IsList (IsList (..))
import Hydra.Contract.Dummy (dummyValidatorScript)
import Hydra.Contract.Util (hydraHeadV1)
import Hydra.Tx.OnChainId (OnChainId (..))
import Ouroboros.Consensus.Shelley.Eras qualified as Ledger
import PlutusLedgerApi.V3 (fromBuiltin, getPubKeyHash)

hydraHeadV1AssetName :: AssetName
hydraHeadV1AssetName :: AssetName
hydraHeadV1AssetName = ByteString -> AssetName
AssetName (BuiltinByteString -> FromBuiltin BuiltinByteString
forall arep. HasFromBuiltin arep => arep -> FromBuiltin arep
fromBuiltin BuiltinByteString
hydraHeadV1)

-- | The metadata label used for identifying Hydra protocol transactions. As
-- suggested by a friendly large language model: The number most commonly
-- associated with "Hydra" is 5, as in the mythological creature Hydra, which
-- had multiple heads, and the number 5 often symbolizes multiplicity or
-- diversity. However, there is no specific numerical association for Hydra
-- smaller than 10000 beyond this mythological reference.
hydraMetadataLabel :: Word64
hydraMetadataLabel :: Word64
hydraMetadataLabel = Word64
55555

-- | Create a transaction metadata entry to identify Hydra transactions (for
-- informational purposes).
mkHydraHeadV1TxName :: Text -> TxMetadata
mkHydraHeadV1TxName :: Text -> TxMetadata
mkHydraHeadV1TxName Text
name =
  Map Word64 TxMetadataValue -> TxMetadata
TxMetadata (Map Word64 TxMetadataValue -> TxMetadata)
-> Map Word64 TxMetadataValue -> TxMetadata
forall a b. (a -> b) -> a -> b
$ [(Word64, TxMetadataValue)] -> Map Word64 TxMetadataValue
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Word64
hydraMetadataLabel, Text -> TxMetadataValue
TxMetaText (Text -> TxMetadataValue) -> Text -> TxMetadataValue
forall a b. (a -> b) -> a -> b
$ Text
"HydraV1/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name)]

assetNameToOnChainId :: AssetName -> OnChainId
assetNameToOnChainId :: AssetName -> OnChainId
assetNameToOnChainId (AssetName ByteString
bs) = ByteString -> OnChainId
UnsafeOnChainId ByteString
bs

onChainIdToAssetName :: OnChainId -> AssetName
onChainIdToAssetName :: OnChainId -> AssetName
onChainIdToAssetName = ByteString -> AssetName
AssetName (ByteString -> AssetName)
-> (OnChainId -> ByteString) -> OnChainId -> AssetName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnChainId -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytes

-- | Find first occurrence including a transformation.
findFirst :: Foldable t => (a -> Maybe b) -> t a -> Maybe b
findFirst :: forall (t :: * -> *) a b.
Foldable t =>
(a -> Maybe b) -> t a -> Maybe b
findFirst a -> Maybe b
fn = First b -> Maybe b
forall a. First a -> Maybe a
getFirst (First b -> Maybe b) -> (t a -> First b) -> t a -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> First b) -> t a -> First b
forall m a. Monoid m => (a -> m) -> t a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Maybe b -> First b
forall a. Maybe a -> First a
First (Maybe b -> First b) -> (a -> Maybe b) -> a -> First b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe b
fn)

-- | Derive the 'OnChainId' from a Cardano 'PaymentKey'. The on-chain identifier
-- is the public key hash as it is also availble to plutus validators.
verificationKeyToOnChainId :: VerificationKey PaymentKey -> OnChainId
verificationKeyToOnChainId :: VerificationKey PaymentKey -> OnChainId
verificationKeyToOnChainId =
  ByteString -> OnChainId
UnsafeOnChainId (ByteString -> OnChainId)
-> (VerificationKey PaymentKey -> ByteString)
-> VerificationKey PaymentKey
-> OnChainId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuiltinByteString -> ByteString
BuiltinByteString -> FromBuiltin BuiltinByteString
forall arep. HasFromBuiltin arep => arep -> FromBuiltin arep
fromBuiltin (BuiltinByteString -> ByteString)
-> (VerificationKey PaymentKey -> BuiltinByteString)
-> VerificationKey PaymentKey
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PubKeyHash -> BuiltinByteString
getPubKeyHash (PubKeyHash -> BuiltinByteString)
-> (VerificationKey PaymentKey -> PubKeyHash)
-> VerificationKey PaymentKey
-> BuiltinByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash PaymentKey -> PubKeyHash
toPlutusKeyHash (Hash PaymentKey -> PubKeyHash)
-> (VerificationKey PaymentKey -> Hash PaymentKey)
-> VerificationKey PaymentKey
-> PubKeyHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VerificationKey PaymentKey -> Hash PaymentKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash

headTokensFromValue :: PlutusScript -> Value -> [(AssetName, Quantity)]
headTokensFromValue :: PlutusScript -> Value -> [(AssetName, Quantity)]
headTokensFromValue PlutusScript
headTokenScript Value
v =
  [ (AssetName
assetName, Quantity
q)
  | (AssetId PolicyId
pid AssetName
assetName, Quantity
q) <- Value -> [Item Value]
forall l. IsList l => l -> [Item l]
toList Value
v
  , PolicyId
pid PolicyId -> PolicyId -> Bool
forall a. Eq a => a -> a -> Bool
== Script PlutusScriptV3 -> PolicyId
forall lang. Script lang -> PolicyId
scriptPolicyId (PlutusScript -> Script PlutusScriptV3
PlutusScript PlutusScript
headTokenScript)
  ]

-- | Split a given UTxO into two, such that the second UTxO is non-empty. This
-- is useful to pick a UTxO to decommit.
splitUTxO :: UTxO -> (UTxO, UTxO)
splitUTxO :: UTxO -> (UTxO, UTxO)
splitUTxO UTxO
utxo =
  case UTxO -> [(TxIn, TxOut CtxUTxO Era)]
forall out. UTxO' out -> [(TxIn, out)]
UTxO.pairs UTxO
utxo of
    [] -> (UTxO
forall a. Monoid a => a
mempty, UTxO
forall a. Monoid a => a
mempty)
    ((TxIn, TxOut CtxUTxO Era)
u : [(TxIn, TxOut CtxUTxO Era)]
us) -> ([(TxIn, TxOut CtxUTxO Era)] -> UTxO
forall out. [(TxIn, out)] -> UTxO' out
UTxO.fromPairs [(TxIn, TxOut CtxUTxO Era)]
us, (TxIn, TxOut CtxUTxO Era) -> UTxO
forall out. (TxIn, out) -> UTxO' out
UTxO.singleton (TxIn, TxOut CtxUTxO Era)
u)

adaOnly :: TxOut CtxUTxO -> TxOut CtxUTxO
adaOnly :: TxOut CtxUTxO Era -> TxOut CtxUTxO Era
adaOnly = \case
  TxOut AddressInEra
addr Value
value TxOutDatum CtxUTxO
datum ReferenceScript
refScript ->
    AddressInEra
-> Value
-> TxOutDatum CtxUTxO
-> ReferenceScript
-> TxOut CtxUTxO Era
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut AddressInEra
addr (Lovelace -> Value
lovelaceToValue (Lovelace -> Value) -> Lovelace -> Value
forall a b. (a -> b) -> a -> b
$ Value -> Lovelace
selectLovelace Value
value) TxOutDatum CtxUTxO
datum ReferenceScript
refScript

addMetadata :: TxMetadata -> Tx -> Ledger.AlonzoTx (Ledger.ConwayEra StandardCrypto) -> Ledger.AlonzoTx (Ledger.ConwayEra StandardCrypto)
addMetadata :: TxMetadata
-> Tx
-> AlonzoTx (ConwayEra StandardCrypto)
-> AlonzoTx (ConwayEra StandardCrypto)
addMetadata (TxMetadata Map Word64 TxMetadataValue
newMetadata) Tx
blueprintTx AlonzoTx (ConwayEra StandardCrypto)
tx =
  let
    newMetadataMap :: Map Word64 Metadatum
newMetadataMap = Map Word64 TxMetadataValue -> Map Word64 Metadatum
toShelleyMetadata Map Word64 TxMetadataValue
newMetadata
    newAuxData :: AlonzoTxAuxData (ConwayEra StandardCrypto)
newAuxData =
      case Tx -> Tx (ShelleyLedgerEra Era)
forall era. Tx era -> Tx (ShelleyLedgerEra era)
toLedgerTx Tx
blueprintTx AlonzoTx (ConwayEra StandardCrypto)
-> Getting
     (StrictMaybe (AlonzoTxAuxData (ConwayEra StandardCrypto)))
     (AlonzoTx (ConwayEra StandardCrypto))
     (StrictMaybe (AlonzoTxAuxData (ConwayEra StandardCrypto)))
-> StrictMaybe (AlonzoTxAuxData (ConwayEra StandardCrypto))
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictMaybe (AlonzoTxAuxData (ConwayEra StandardCrypto)))
  (AlonzoTx (ConwayEra StandardCrypto))
  (StrictMaybe (AlonzoTxAuxData (ConwayEra StandardCrypto)))
(StrictMaybe (AuxiliaryData (ConwayEra StandardCrypto))
 -> Const
      (StrictMaybe (AlonzoTxAuxData (ConwayEra StandardCrypto)))
      (StrictMaybe (AuxiliaryData (ConwayEra StandardCrypto))))
-> Tx (ConwayEra StandardCrypto)
-> Const
     (StrictMaybe (AlonzoTxAuxData (ConwayEra StandardCrypto)))
     (Tx (ConwayEra StandardCrypto))
forall era.
EraTx era =>
Lens' (Tx era) (StrictMaybe (AuxiliaryData era))
Lens'
  (Tx (ConwayEra StandardCrypto))
  (StrictMaybe (AuxiliaryData (ConwayEra StandardCrypto)))
auxDataTxL of
        StrictMaybe (AlonzoTxAuxData (ConwayEra StandardCrypto))
SNothing -> Map Word64 Metadatum
-> StrictSeq (Timelock (ConwayEra StandardCrypto))
-> Map Language (NonEmpty PlutusBinary)
-> AlonzoTxAuxData (ConwayEra StandardCrypto)
forall era.
(HasCallStack, AlonzoEraScript era) =>
Map Word64 Metadatum
-> StrictSeq (Timelock era)
-> Map Language (NonEmpty PlutusBinary)
-> AlonzoTxAuxData era
AlonzoTxAuxData Map Word64 Metadatum
newMetadataMap StrictSeq (Timelock (ConwayEra StandardCrypto))
forall a. Monoid a => a
mempty Map Language (NonEmpty PlutusBinary)
forall a. Monoid a => a
mempty
        SJust (AlonzoTxAuxData Map Word64 Metadatum
metadata StrictSeq (Timelock (ConwayEra StandardCrypto))
timeLocks Map Language (NonEmpty PlutusBinary)
languageMap) ->
          Map Word64 Metadatum
-> StrictSeq (Timelock (ConwayEra StandardCrypto))
-> Map Language (NonEmpty PlutusBinary)
-> AlonzoTxAuxData (ConwayEra StandardCrypto)
forall era.
(HasCallStack, AlonzoEraScript era) =>
Map Word64 Metadatum
-> StrictSeq (Timelock era)
-> Map Language (NonEmpty PlutusBinary)
-> AlonzoTxAuxData era
AlonzoTxAuxData (Map Word64 Metadatum
-> Map Word64 Metadatum -> Map Word64 Metadatum
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map Word64 Metadatum
metadata Map Word64 Metadatum
newMetadataMap) StrictSeq (Timelock (ConwayEra StandardCrypto))
timeLocks Map Language (NonEmpty PlutusBinary)
languageMap
   in
    AlonzoTx (ConwayEra StandardCrypto)
tx
      AlonzoTx (ConwayEra StandardCrypto)
-> (AlonzoTx (ConwayEra StandardCrypto)
    -> AlonzoTx (ConwayEra StandardCrypto))
-> AlonzoTx (ConwayEra StandardCrypto)
forall a b. a -> (a -> b) -> b
& (StrictMaybe (AuxiliaryData (ConwayEra StandardCrypto))
 -> Identity
      (StrictMaybe (AlonzoTxAuxData (ConwayEra StandardCrypto))))
-> AlonzoTx (ConwayEra StandardCrypto)
-> Identity (AlonzoTx (ConwayEra StandardCrypto))
(StrictMaybe (AuxiliaryData (ConwayEra StandardCrypto))
 -> Identity
      (StrictMaybe (AuxiliaryData (ConwayEra StandardCrypto))))
-> Tx (ConwayEra StandardCrypto)
-> Identity (Tx (ConwayEra StandardCrypto))
forall era.
EraTx era =>
Lens' (Tx era) (StrictMaybe (AuxiliaryData era))
Lens'
  (Tx (ConwayEra StandardCrypto))
  (StrictMaybe (AuxiliaryData (ConwayEra StandardCrypto)))
auxDataTxL ((StrictMaybe (AuxiliaryData (ConwayEra StandardCrypto))
  -> Identity
       (StrictMaybe (AlonzoTxAuxData (ConwayEra StandardCrypto))))
 -> AlonzoTx (ConwayEra StandardCrypto)
 -> Identity (AlonzoTx (ConwayEra StandardCrypto)))
-> StrictMaybe (AlonzoTxAuxData (ConwayEra StandardCrypto))
-> AlonzoTx (ConwayEra StandardCrypto)
-> AlonzoTx (ConwayEra StandardCrypto)
forall s t a b. ASetter s t a b -> b -> s -> t
.~ AlonzoTxAuxData (ConwayEra StandardCrypto)
-> StrictMaybe (AlonzoTxAuxData (ConwayEra StandardCrypto))
forall a. a -> StrictMaybe a
SJust AlonzoTxAuxData (ConwayEra StandardCrypto)
newAuxData
      AlonzoTx (ConwayEra StandardCrypto)
-> (AlonzoTx (ConwayEra StandardCrypto)
    -> AlonzoTx (ConwayEra StandardCrypto))
-> AlonzoTx (ConwayEra StandardCrypto)
forall a b. a -> (a -> b) -> b
& (TxBody (ConwayEra StandardCrypto)
 -> Identity (TxBody (ConwayEra StandardCrypto)))
-> Tx (ConwayEra StandardCrypto)
-> Identity (Tx (ConwayEra StandardCrypto))
(TxBody (ConwayEra StandardCrypto)
 -> Identity (TxBody (ConwayEra StandardCrypto)))
-> AlonzoTx (ConwayEra StandardCrypto)
-> Identity (AlonzoTx (ConwayEra StandardCrypto))
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens'
  (Tx (ConwayEra StandardCrypto)) (TxBody (ConwayEra StandardCrypto))
bodyTxL ((TxBody (ConwayEra StandardCrypto)
  -> Identity (TxBody (ConwayEra StandardCrypto)))
 -> AlonzoTx (ConwayEra StandardCrypto)
 -> Identity (AlonzoTx (ConwayEra StandardCrypto)))
-> ((StrictMaybe
       (AuxiliaryDataHash (EraCrypto (ConwayEra StandardCrypto)))
     -> Identity
          (StrictMaybe
             (AuxiliaryDataHash (EraCrypto (ConwayEra StandardCrypto)))))
    -> TxBody (ConwayEra StandardCrypto)
    -> Identity (TxBody (ConwayEra StandardCrypto)))
-> (StrictMaybe
      (AuxiliaryDataHash (EraCrypto (ConwayEra StandardCrypto)))
    -> Identity
         (StrictMaybe
            (AuxiliaryDataHash (EraCrypto (ConwayEra StandardCrypto)))))
-> AlonzoTx (ConwayEra StandardCrypto)
-> Identity (AlonzoTx (ConwayEra StandardCrypto))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe
   (AuxiliaryDataHash (EraCrypto (ConwayEra StandardCrypto)))
 -> Identity
      (StrictMaybe
         (AuxiliaryDataHash (EraCrypto (ConwayEra StandardCrypto)))))
-> TxBody (ConwayEra StandardCrypto)
-> Identity (TxBody (ConwayEra StandardCrypto))
forall era.
EraTxBody era =>
Lens'
  (TxBody era) (StrictMaybe (AuxiliaryDataHash (EraCrypto era)))
Lens'
  (TxBody (ConwayEra StandardCrypto))
  (StrictMaybe
     (AuxiliaryDataHash (EraCrypto (ConwayEra StandardCrypto))))
auxDataHashTxBodyL ((StrictMaybe
    (AuxiliaryDataHash (EraCrypto (ConwayEra StandardCrypto)))
  -> Identity
       (StrictMaybe
          (AuxiliaryDataHash (EraCrypto (ConwayEra StandardCrypto)))))
 -> AlonzoTx (ConwayEra StandardCrypto)
 -> Identity (AlonzoTx (ConwayEra StandardCrypto)))
-> StrictMaybe
     (AuxiliaryDataHash (EraCrypto (ConwayEra StandardCrypto)))
-> AlonzoTx (ConwayEra StandardCrypto)
-> AlonzoTx (ConwayEra StandardCrypto)
forall s t a b. ASetter s t a b -> b -> s -> t
.~ AuxiliaryDataHash (EraCrypto (ConwayEra StandardCrypto))
-> StrictMaybe
     (AuxiliaryDataHash (EraCrypto (ConwayEra StandardCrypto)))
forall a. a -> StrictMaybe a
SJust (AuxiliaryData (ConwayEra StandardCrypto)
-> AuxiliaryDataHash (EraCrypto (ConwayEra StandardCrypto))
forall era.
EraTxAuxData era =>
TxAuxData era -> AuxiliaryDataHash (EraCrypto era)
hashTxAuxData AlonzoTxAuxData (ConwayEra StandardCrypto)
AuxiliaryData (ConwayEra StandardCrypto)
newAuxData)