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

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

import Cardano.Ledger.Api (AlonzoTxAuxData (..), auxDataHashTxBodyL, auxDataTxL, bodyTxL, hashTxAuxData)
import Cardano.Ledger.Core (TxLevel (..))
import Cardano.Ledger.Core qualified as LedgerCore
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 (hydraHeadV2)
import Hydra.Tx.HeadId (HeadId, mkHeadId)
import Hydra.Tx.OnChainId (OnChainId (..))
import PlutusLedgerApi.V3 (fromBuiltin, getPubKeyHash)

hydraHeadV2AssetName :: AssetName
hydraHeadV2AssetName :: AssetName
hydraHeadV2AssetName = ByteString -> AssetName
UnsafeAssetName (BuiltinByteString -> FromBuiltin BuiltinByteString
forall arep. HasFromBuiltin arep => arep -> FromBuiltin arep
fromBuiltin BuiltinByteString
hydraHeadV2)

-- | 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).
mkHydraHeadV2TxName :: Text -> TxMetadata
mkHydraHeadV2TxName :: Text -> TxMetadata
mkHydraHeadV2TxName 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
"HydraV2/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name)]

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

onChainIdToAssetName :: OnChainId -> AssetName
onChainIdToAssetName :: OnChainId -> AssetName
onChainIdToAssetName = ByteString -> AssetName
UnsafeAssetName (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 available 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 -> PolicyAssets
headTokensFromValue :: PlutusScript -> Value -> PolicyAssets
headTokensFromValue PlutusScript
headTokenScript Value
v =
  [Item PolicyAssets] -> PolicyAssets
forall l. IsList l => [Item l] -> l
fromList ([Item PolicyAssets] -> PolicyAssets)
-> [Item PolicyAssets] -> PolicyAssets
forall a b. (a -> b) -> a -> b
$
    [ (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)
    ]

addMetadata :: TxMetadata -> Tx -> LedgerCore.Tx TopTx LedgerEra -> LedgerCore.Tx TopTx LedgerEra
addMetadata :: TxMetadata -> Tx -> Tx TopTx LedgerEra -> Tx TopTx LedgerEra
addMetadata (TxMetadata Map Word64 TxMetadataValue
newMetadata) Tx
blueprintTx Tx TopTx LedgerEra
tx =
  let
    newMetadataMap :: Map Word64 Metadatum
newMetadataMap = Map Word64 TxMetadataValue -> Map Word64 Metadatum
toShelleyMetadata Map Word64 TxMetadataValue
newMetadata
    newAuxData :: AlonzoTxAuxData ConwayEra
newAuxData =
      case Tx -> Tx TopTx LedgerEra
forall era. Tx era -> Tx TopTx (ShelleyLedgerEra era)
toLedgerTx Tx
blueprintTx Tx TopTx ConwayEra
-> Getting
     (StrictMaybe (AlonzoTxAuxData ConwayEra))
     (Tx TopTx ConwayEra)
     (StrictMaybe (AlonzoTxAuxData ConwayEra))
-> StrictMaybe (AlonzoTxAuxData ConwayEra)
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictMaybe (AlonzoTxAuxData ConwayEra))
  (Tx TopTx ConwayEra)
  (StrictMaybe (AlonzoTxAuxData ConwayEra))
(StrictMaybe (TxAuxData ConwayEra)
 -> Const
      (StrictMaybe (AlonzoTxAuxData ConwayEra))
      (StrictMaybe (TxAuxData ConwayEra)))
-> Tx TopTx ConwayEra
-> Const
     (StrictMaybe (AlonzoTxAuxData ConwayEra)) (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (StrictMaybe (TxAuxData era))
forall (l :: TxLevel).
Lens' (Tx l ConwayEra) (StrictMaybe (TxAuxData ConwayEra))
auxDataTxL of
        StrictMaybe (AlonzoTxAuxData ConwayEra)
SNothing -> Map Word64 Metadatum
-> StrictSeq (NativeScript ConwayEra)
-> Map Language (NonEmpty PlutusBinary)
-> AlonzoTxAuxData ConwayEra
forall era.
(HasCallStack, AlonzoEraScript era) =>
Map Word64 Metadatum
-> StrictSeq (NativeScript era)
-> Map Language (NonEmpty PlutusBinary)
-> AlonzoTxAuxData era
AlonzoTxAuxData Map Word64 Metadatum
newMetadataMap StrictSeq (NativeScript ConwayEra)
forall a. Monoid a => a
mempty Map Language (NonEmpty PlutusBinary)
forall a. Monoid a => a
mempty
        SJust (AlonzoTxAuxData Map Word64 Metadatum
metadata StrictSeq (NativeScript ConwayEra)
timeLocks Map Language (NonEmpty PlutusBinary)
languageMap) ->
          Map Word64 Metadatum
-> StrictSeq (NativeScript ConwayEra)
-> Map Language (NonEmpty PlutusBinary)
-> AlonzoTxAuxData ConwayEra
forall era.
(HasCallStack, AlonzoEraScript era) =>
Map Word64 Metadatum
-> StrictSeq (NativeScript 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 (NativeScript ConwayEra)
timeLocks Map Language (NonEmpty PlutusBinary)
languageMap
   in
    Tx TopTx LedgerEra
Tx TopTx ConwayEra
tx
      Tx TopTx ConwayEra
-> (Tx TopTx ConwayEra -> Tx TopTx ConwayEra) -> Tx TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (StrictMaybe (AlonzoTxAuxData ConwayEra)
 -> Identity (StrictMaybe (AlonzoTxAuxData ConwayEra)))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
(StrictMaybe (TxAuxData ConwayEra)
 -> Identity (StrictMaybe (TxAuxData ConwayEra)))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (StrictMaybe (TxAuxData era))
forall (l :: TxLevel).
Lens' (Tx l ConwayEra) (StrictMaybe (TxAuxData ConwayEra))
auxDataTxL ((StrictMaybe (AlonzoTxAuxData ConwayEra)
  -> Identity (StrictMaybe (AlonzoTxAuxData ConwayEra)))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> StrictMaybe (AlonzoTxAuxData ConwayEra)
-> Tx TopTx ConwayEra
-> Tx TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ AlonzoTxAuxData ConwayEra
-> StrictMaybe (AlonzoTxAuxData ConwayEra)
forall a. a -> StrictMaybe a
SJust AlonzoTxAuxData ConwayEra
newAuxData
      Tx TopTx ConwayEra
-> (Tx TopTx ConwayEra -> Tx TopTx ConwayEra) -> Tx TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxBody l ConwayEra)
bodyTxL ((TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> ((StrictMaybe TxAuxDataHash
     -> Identity (StrictMaybe TxAuxDataHash))
    -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> (StrictMaybe TxAuxDataHash
    -> Identity (StrictMaybe TxAuxDataHash))
-> Tx TopTx ConwayEra
-> Identity (Tx TopTx ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe TxAuxDataHash -> Identity (StrictMaybe TxAuxDataHash))
-> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictMaybe TxAuxDataHash)
forall (l :: TxLevel).
Lens' (TxBody l ConwayEra) (StrictMaybe TxAuxDataHash)
auxDataHashTxBodyL ((StrictMaybe TxAuxDataHash
  -> Identity (StrictMaybe TxAuxDataHash))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> StrictMaybe TxAuxDataHash
-> Tx TopTx ConwayEra
-> Tx TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxAuxDataHash -> StrictMaybe TxAuxDataHash
forall a. a -> StrictMaybe a
SJust (TxAuxData ConwayEra -> TxAuxDataHash
forall era. EraTxAuxData era => TxAuxData era -> TxAuxDataHash
hashTxAuxData AlonzoTxAuxData ConwayEra
TxAuxData ConwayEra
newAuxData)

-- | Type to encapsulate one of the two possible incremental actions or a
-- regular snapshot. This actually signals that our snapshot modeling is likely
-- not ideal but for now we want to keep track of both fields (de/commit) since
-- we might want to support batch de/commits too in the future, but having both fields
-- be Maybe UTxO introduces a lot of checks if the value is Nothing or mempty.
data IncrementalAction = ToCommit | ToDecommit | NoThing deriving stock (IncrementalAction -> IncrementalAction -> Bool
(IncrementalAction -> IncrementalAction -> Bool)
-> (IncrementalAction -> IncrementalAction -> Bool)
-> Eq IncrementalAction
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IncrementalAction -> IncrementalAction -> Bool
== :: IncrementalAction -> IncrementalAction -> Bool
$c/= :: IncrementalAction -> IncrementalAction -> Bool
/= :: IncrementalAction -> IncrementalAction -> Bool
Eq, Int -> IncrementalAction -> ShowS
[IncrementalAction] -> ShowS
IncrementalAction -> String
(Int -> IncrementalAction -> ShowS)
-> (IncrementalAction -> String)
-> ([IncrementalAction] -> ShowS)
-> Show IncrementalAction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IncrementalAction -> ShowS
showsPrec :: Int -> IncrementalAction -> ShowS
$cshow :: IncrementalAction -> String
show :: IncrementalAction -> String
$cshowList :: [IncrementalAction] -> ShowS
showList :: [IncrementalAction] -> ShowS
Show)

setIncrementalActionMaybe :: Maybe UTxO -> Maybe UTxO -> Maybe IncrementalAction
setIncrementalActionMaybe :: Maybe UTxO -> Maybe UTxO -> Maybe IncrementalAction
setIncrementalActionMaybe Maybe UTxO
utxoToCommit Maybe UTxO
utxoToDecommit =
  case (Maybe UTxO
utxoToCommit, Maybe UTxO
utxoToDecommit) of
    (Just UTxO
_, Just UTxO
_) -> Maybe IncrementalAction
forall a. Maybe a
Nothing
    (Just UTxO
_, Maybe UTxO
Nothing) -> IncrementalAction -> Maybe IncrementalAction
forall a. a -> Maybe a
Just IncrementalAction
ToCommit
    (Maybe UTxO
Nothing, Just UTxO
_) -> IncrementalAction -> Maybe IncrementalAction
forall a. a -> Maybe a
Just IncrementalAction
ToDecommit
    (Maybe UTxO
Nothing, Maybe UTxO
Nothing) -> IncrementalAction -> Maybe IncrementalAction
forall a. a -> Maybe a
Just IncrementalAction
NoThing

-- | Find (if it exists) the head identifier contained in given `TxOut`.
findStateToken :: TxOut ctx -> Maybe HeadId
findStateToken :: forall ctx. TxOut ctx -> Maybe HeadId
findStateToken =
  ((PolicyId, AssetName) -> HeadId)
-> Maybe (PolicyId, AssetName) -> 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 (PolicyId -> HeadId)
-> ((PolicyId, AssetName) -> PolicyId)
-> (PolicyId, AssetName)
-> HeadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PolicyId, AssetName) -> PolicyId
forall a b. (a, b) -> a
fst) (Maybe (PolicyId, AssetName) -> Maybe HeadId)
-> (TxOut ctx -> Maybe (PolicyId, AssetName))
-> TxOut ctx
-> Maybe HeadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut ctx -> Maybe (PolicyId, AssetName)
forall ctx. TxOut ctx -> Maybe (PolicyId, AssetName)
findHeadAssetId

findHeadAssetId :: TxOut ctx -> Maybe (PolicyId, AssetName)
findHeadAssetId :: forall ctx. TxOut ctx -> Maybe (PolicyId, AssetName)
findHeadAssetId TxOut ctx
txOut =
  (((AssetId, Quantity) -> Maybe (PolicyId, AssetName))
 -> [(AssetId, Quantity)] -> Maybe (PolicyId, AssetName))
-> [(AssetId, Quantity)]
-> ((AssetId, Quantity) -> Maybe (PolicyId, AssetName))
-> Maybe (PolicyId, AssetName)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((AssetId, Quantity) -> Maybe (PolicyId, AssetName))
-> [(AssetId, Quantity)] -> Maybe (PolicyId, AssetName)
forall (t :: * -> *) a b.
Foldable t =>
(a -> Maybe b) -> t a -> Maybe b
findFirst (Value -> [Item Value]
forall l. IsList l => l -> [Item l]
toList (Value -> [Item Value]) -> Value -> [Item Value]
forall a b. (a -> b) -> a -> b
$ TxOut ctx -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut ctx
txOut) (((AssetId, Quantity) -> Maybe (PolicyId, AssetName))
 -> Maybe (PolicyId, AssetName))
-> ((AssetId, Quantity) -> Maybe (PolicyId, AssetName))
-> Maybe (PolicyId, AssetName)
forall a b. (a -> b) -> a -> b
$ \case
    (AssetId PolicyId
pid AssetName
aname, Quantity
q)
      | AssetName
aname AssetName -> AssetName -> Bool
forall a. Eq a => a -> a -> Bool
== AssetName
hydraHeadV2AssetName Bool -> Bool -> Bool
&& Quantity
q Quantity -> Quantity -> Bool
forall a. Eq a => a -> a -> Bool
== Quantity
1 ->
          (PolicyId, AssetName) -> Maybe (PolicyId, AssetName)
forall a. a -> Maybe a
Just (PolicyId
pid, AssetName
aname)
    (AssetId, Quantity)
_ ->
      Maybe (PolicyId, AssetName)
forall a. Maybe a
Nothing