diff --git a/cem-script.cabal b/cem-script.cabal index d536459..b1defbd 100644 --- a/cem-script.cabal +++ b/cem-script.cabal @@ -145,7 +145,9 @@ library Cardano.CEM.Examples.Auction Cardano.CEM.Examples.Compilation Cardano.CEM.Examples.Voting - Cardano.CEM.Indexing + Cardano.CEM.Indexing.Event + Cardano.CEM.Indexing.Oura + Cardano.CEM.Indexing.Tx Cardano.CEM.Monads Cardano.CEM.Monads.CLB Cardano.CEM.Monads.L1 @@ -156,15 +158,20 @@ library other-modules: Cardano.CEM.Monads.L1Commons build-depends: + , base16 + , base64 , cem-script:cardano-extras , cem-script:data-spine , clb , dependent-map + , lens , ouroboros-consensus , QuickCheck , quickcheck-dynamic + , safe , singletons-th , toml-parser + , vector test-suite cem-sdk-test import: @@ -206,12 +213,10 @@ test-suite cem-sdk-test Auction Dynamic OffChain - Oura Oura.Communication - Oura.Config - OuraFilters OuraFilters.Auction OuraFilters.Mock + OuraFilters.Simple TestNFT Utils Voting diff --git a/src/Cardano/CEM/Examples.hs b/src/Cardano/CEM/Examples.hs deleted file mode 100644 index e69de29..0000000 diff --git a/src/Cardano/CEM/Indexing/Event.hs b/src/Cardano/CEM/Indexing/Event.hs new file mode 100644 index 0000000..11241e5 --- /dev/null +++ b/src/Cardano/CEM/Indexing/Event.hs @@ -0,0 +1,147 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Indexer events, i.e. indexer outputs. +module Cardano.CEM.Indexing.Event where + +import Cardano.Api qualified as C +import Cardano.Api.ScriptData qualified as C +import Cardano.Api.SerialiseRaw qualified as SerialiseRaw +import Cardano.CEM (CEMScript, CEMScriptDatum, State, Transition, transitionStage) +import Cardano.CEM.Address qualified as Address +import Cardano.CEM.Indexing.Tx +import Cardano.CEM.OnChain (CEMScriptCompiled, CEMScriptIsData) +import Cardano.Ledger.BaseTypes qualified as Ledger +import Control.Lens (view, (^.)) +import Data.Bifunctor (first) +import Data.ByteString.Base16 qualified as B16 +import Data.Data (Proxy (Proxy)) +import Data.Either.Extra (eitherToMaybe) +import Data.Function ((&)) +import Data.List (find) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromJust) +import Data.Spine (Spine, getSpine) +import Data.Text.Encoding (encodeUtf8) +import Data.Tuple (swap) +import PlutusLedgerApi.V1 (FromData) +import PlutusLedgerApi.V1 qualified +import Prelude + +-- --- + +{- | Indexer events. + We extract events from transactions, where we can encounter three situations: + + (1) For the very first transition there is only target datum and no redeemer. + In that case we can only restore the name of the transition, + i.e. 'Spine Transition' + + (2) For intermidiate transitions we have both datums that identify them and + additionally redeemer, that contains the whole transition. In that case + we can restore the whole transition. + + (3) For the final transition the situation is like (2) except the target + datum is missing, which doesn't matter. + + + TODO: How we can improve this in the future: + * API is probably bad, as we always have some transition like Init state - + which you can decode, as you have State. If one changes data + `CEMAction script = MkCEMAction (Params script) (Transition script)` to + `... = Init (Params script) (State script) + | Transition (Params script) (Transition script)` + one could reuse this datatype in all situations. +-} +data IndexerEvent script + = Initial (Spine (Transition script)) + | -- | TODO: Migrate from (Spine (Transition script)) to (Transition script) + -- once we have this done: https://github.com/utxorpc/spec/issues/132 + Following (Spine (Transition script)) -- (Transition script) + +deriving stock instance + (Show (Spine (Transition script))) => + (Show (IndexerEvent script)) +deriving stock instance + (Eq (Spine (Transition script))) => + (Eq (IndexerEvent script)) + +{- | The core function, that extracts an Event out of a Oura transaction. +It might be a pure function, IO here was used mostly to simplify debugging +during its development. +-} +extractEvent :: + forall script. + ( CEMScript script + , CEMScriptIsData script + , CEMScriptCompiled script + ) => + Ledger.Network -> + Tx -> + IO (Maybe (IndexerEvent script)) +extractEvent network tx = do + -- Script payemnt credential based predicate + let ~(Right scriptAddr) = Address.scriptCardanoAddress (Proxy @script) network + let cPred = hasAddr scriptAddr + + -- Source state + let mOwnInput :: Maybe TxInput = find (cPred . view as_output) (tx ^. inputs) + let mSourceState :: Maybe (State script) = (extractState . view as_output) =<< mOwnInput + let mSourceSpine :: Maybe (Spine (State script)) = getSpine <$> mSourceState + + -- Target state + let mOwnOutput :: Maybe TxOutput = find cPred $ tx ^. outputs + let mTargetState :: Maybe (State script) = extractState =<< mOwnOutput + let mTargetSpine :: Maybe (Spine (State script)) = getSpine <$> mTargetState + + -- Look up the transition + let transitions = + first + (\(_, b, c) -> (b, c)) + . swap + <$> Map.toList (transitionStage $ Proxy @script) + let transSpine = lookup (mSourceSpine, mTargetSpine) transitions + + -- Return + case mOwnInput of + Nothing -> pure $ Initial <$> transSpine + Just _ownInput -> do + -- TODO: fix once Oura has rawCbor for redeemer + -- rdm <- ownInput ^. redeemer + -- pure $ Following $ undefined (rdm ^. redeemerPayload) + pure $ Following <$> transSpine + +extractState :: + forall script. + (FromData (CEMScriptDatum script)) => + TxOutput -> + Maybe (State script) +extractState MkTxOutput {_datum = mDtm} = + case mDtm of + Nothing -> Nothing + Just dtm -> do + let MkDatum _ _ cbor = dtm + let datumAsData :: PlutusLedgerApi.V1.Data = + cbor + & C.toPlutusData + . C.getScriptData + . fromJust + . eitherToMaybe + . C.deserialiseFromCBOR C.AsHashableScriptData + . B16.decodeBase16Lenient -- use base64 + . encodeUtf8 + let ~(Just (_, _, state)) = PlutusLedgerApi.V1.fromData @(CEMScriptDatum script) datumAsData + pure state + +hasAddr :: C.Address C.ShelleyAddr -> TxOutput -> Bool +hasAddr addr' output = + let addr = output ^. address + in fromOuraAddress addr == addr' + +fromOuraAddress :: Address -> C.Address C.ShelleyAddr +fromOuraAddress (MkAddressAsBase64 addr) = + addr + & fromJust + . eitherToMaybe + . SerialiseRaw.deserialiseFromRawBytes (C.AsAddress C.AsShelleyAddr) + . B16.decodeBase16Lenient -- use base64 + . encodeUtf8 diff --git a/src/Cardano/CEM/Indexing.hs b/src/Cardano/CEM/Indexing/Oura.hs similarity index 94% rename from src/Cardano/CEM/Indexing.hs rename to src/Cardano/CEM/Indexing/Oura.hs index f469225..4f2d9cb 100644 --- a/src/Cardano/CEM/Indexing.hs +++ b/src/Cardano/CEM/Indexing/Oura.hs @@ -1,4 +1,8 @@ -module Cardano.CEM.Indexing ( +{- | CEM provides the building blocks to build an indexer for your dApp. +Current implementation is based on Oura. This module provides tools to +run Oura. +-} +module Cardano.CEM.Indexing.Oura ( SourcePath (MkSourcePath, unSourcePath), SinkPath (MkSinkPath, unSinkPath), Filter (MkFilter, unFilter), diff --git a/src/Cardano/CEM/Indexing/Tx.hs b/src/Cardano/CEM/Indexing/Tx.hs new file mode 100644 index 0000000..f5d3471 --- /dev/null +++ b/src/Cardano/CEM/Indexing/Tx.hs @@ -0,0 +1,446 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Use fewer imports" #-} + +-- | Indexer inputs, Txs as they are represented by Oura. +module Cardano.CEM.Indexing.Tx where + +import Cardano.Api (TxIn, UTxO) +import Cardano.Api qualified as C +import Cardano.Api.Address qualified as C (Address (..)) +import Cardano.Api.SerialiseRaw qualified as SerialiseRaw +import Cardano.CEM.Address qualified as Address +import Cardano.Extras (Era) +import Cardano.Ledger.BaseTypes qualified as Ledger +import Control.Lens.TH (makeLenses, makeLensesFor) +import Control.Monad ((<=<)) +import Data.Aeson (KeyValue ((.=))) +import Data.Aeson qualified as Aeson +import Data.Base16.Types qualified as B16 +import Data.Base64.Types qualified as B64 +import Data.ByteString qualified as BS +import Data.ByteString.Base16 qualified as B16 +import Data.ByteString.Base64 qualified as B64 +import Data.Function ((&)) +import Data.Functor ((<&>)) +import Data.Map.Strict qualified as Map +import Data.Maybe (mapMaybe) +import Data.Text qualified as T +import Data.Vector qualified as Vec +import GHC.Generics (Generic (Rep)) +import GHC.Stack.Types (HasCallStack) +import PlutusLedgerApi.V1 qualified +import Safe +import Prelude + +-- Core datatypes + +newtype WithoutUnderscore a = MkWithoutUnderscore a + deriving newtype (Generic) + +withoutLeadingUnderscore :: Aeson.Options +withoutLeadingUnderscore = + Aeson.defaultOptions + { Aeson.fieldLabelModifier = \case + '_' : fieldName -> fieldName + fieldName -> fieldName + } +instance + ( Generic a + , Aeson.GToJSON' Aeson.Value Aeson.Zero (GHC.Generics.Rep a) + ) => + Aeson.ToJSON (WithoutUnderscore a) + where + toJSON = Aeson.genericToJSON withoutLeadingUnderscore + +instance (Generic a, Aeson.GFromJSON Aeson.Zero (Rep a)) => Aeson.FromJSON (WithoutUnderscore a) where + parseJSON = Aeson.genericParseJSON withoutLeadingUnderscore + +newtype Address = MkAddressAsBase64 {_addressL :: T.Text} + deriving newtype (Show, Eq, Ord, Aeson.ToJSON, Aeson.FromJSON) +makeLenses ''Address + +-- 32B long +newtype Hash32 = MkBlake2b255Hex {unHash32 :: T.Text} + deriving newtype (Show, Eq, Ord) + deriving newtype (Aeson.ToJSON) + deriving newtype (Aeson.FromJSON) +makeLenses ''Hash32 + +-- 28B long +newtype Hash28 = MkBlake2b244Hex {unHash28 :: T.Text} + deriving newtype (Show, Eq, Ord) + deriving newtype (Aeson.ToJSON) + deriving newtype (Aeson.FromJSON) +makeLenses ''Hash28 + +data Asset = MkAsset + { _name :: T.Text + , _output_coin :: Integer -- positive + , _mint_coin :: Integer + } + deriving stock (Generic) + deriving (Aeson.ToJSON) via (WithoutUnderscore Asset) + deriving (Aeson.FromJSON) via (WithoutUnderscore Asset) +makeLenses ''Asset + +data Multiasset = MkMultiasset + { _policy_id :: Hash28 + , assets :: [Asset] + } + deriving stock (Generic) + deriving (Aeson.ToJSON) via (WithoutUnderscore Multiasset) + deriving (Aeson.FromJSON) via (WithoutUnderscore Multiasset) +makeLenses ''Multiasset +makeLensesFor + [ ("assets", "multiassetAssets") + ] + ''Multiasset + +newtype PlutusData = MkPlutusData {_plutusData :: Aeson.Value} + deriving newtype (Generic) + deriving newtype (Aeson.FromJSON, Aeson.ToJSON) +makeLenses ''PlutusData + +data Purpose + = PURPOSE_UNSPECIFIED + | PURPOSE_SPEND + | PURPOSE_MINT + | PURPOSE_CERT + | PURPOSE_REWARD + deriving stock (Show, Enum, Bounded) + +instance Aeson.FromJSON Purpose where + parseJSON = + maybe (fail "There is no Purpose case with this Id") pure + . toEnumMay + <=< Aeson.parseJSON @Int + +instance Aeson.ToJSON Purpose where + toJSON = Aeson.toJSON @Int . fromEnum + +data Datum = MkDatum + { hash :: Hash32 + , _payload :: PlutusData + , _original_cbor :: T.Text + } + deriving stock (Generic) + deriving (Aeson.ToJSON) via (WithoutUnderscore Datum) + deriving (Aeson.FromJSON) via (WithoutUnderscore Datum) +makeLenses ''Datum +makeLensesFor [("hash", "datumHash")] ''Datum + +data Redeemer = MkRedeemer + { _purpose :: Purpose + , payload :: PlutusData + } + deriving stock (Generic) + deriving (Aeson.ToJSON) via (WithoutUnderscore Redeemer) + deriving (Aeson.FromJSON) via (WithoutUnderscore Redeemer) +makeLenses ''Redeemer +makeLensesFor [("payload", "redeemerPayload")] ''Redeemer + +data TxOutput = MkTxOutput + { _address :: Address + , _coin :: Integer + , _assets :: [Multiasset] + , _datum :: Maybe Datum + , _script :: Maybe Aeson.Value + } + deriving stock (Generic) + deriving (Aeson.ToJSON) via (WithoutUnderscore TxOutput) + deriving (Aeson.FromJSON) via (WithoutUnderscore TxOutput) +makeLenses ''TxOutput + +data TxInput = MkTxInput + { _tx_hash :: Hash32 + , _output_index :: Integer + , _as_output :: TxOutput + , _redeemer :: Maybe Redeemer + } + deriving stock (Generic) + deriving (Aeson.ToJSON) via (WithoutUnderscore TxInput) + deriving (Aeson.FromJSON) via (WithoutUnderscore TxInput) +makeLenses ''TxInput + +data TxWitnesses = MkTxWitnesses + { _vkeywitness :: [Aeson.Value] + , script :: [Aeson.Value] + , _plutus_datums :: [Aeson.Value] + } + deriving stock (Generic) + deriving (Aeson.ToJSON) via (WithoutUnderscore TxWitnesses) + deriving (Aeson.FromJSON) via (WithoutUnderscore TxWitnesses) + +makeLenses ''TxWitnesses +makeLensesFor [("script", "txWitnessesScript")] ''Multiasset + +data TxCollateral = MkTxCollateral + { _collateral :: [Aeson.Value] + , _collateral_return :: TxOutput + , _total_collateral :: Integer + } + deriving stock (Generic) + deriving (Aeson.ToJSON) via (WithoutUnderscore TxCollateral) + deriving (Aeson.FromJSON) via (WithoutUnderscore TxCollateral) +makeLenses ''TxCollateral + +data TxValidity = MkTxValidity + { _start :: Integer + , _ttl :: Integer + } + deriving stock (Generic) + deriving (Aeson.ToJSON) via (WithoutUnderscore TxValidity) + deriving (Aeson.FromJSON) via (WithoutUnderscore TxValidity) +makeLenses ''TxValidity + +data TxAuxiliary = MkTxAuxiliary + { _metadata :: [Aeson.Value] + , _scripts :: [Aeson.Value] + } + deriving stock (Generic) + deriving (Aeson.ToJSON) via (WithoutUnderscore TxAuxiliary) + deriving (Aeson.FromJSON) via (WithoutUnderscore TxAuxiliary) +makeLenses ''TxAuxiliary + +arbitraryTx :: Tx +arbitraryTx = + MkTx + { _inputs = [] + , _outputs = [] + , _certificates = [] + , _withdrawals = [] + , _mint = [] + , _reference_inputs = [] + , _witnesses = + MkTxWitnesses + { _vkeywitness = [] + , script = [] + , _plutus_datums = [] + } + , collateral = + MkTxCollateral + { _collateral = [] + , _collateral_return = + MkTxOutput + { _address = MkAddressAsBase64 "cM+tGRS1mdGL/9FNK71pYBnCiZy91qAzJc32gLw=" + , _coin = 0 + , _assets = [] + , _datum = Nothing + , _script = Nothing + } + , _total_collateral = 0 + } + , _fee = 0 + , _validity = + MkTxValidity + { _start = 0 + , _ttl = 0 + } + , _successful = True + , _auxiliary = + MkTxAuxiliary + { _metadata = [] + , _scripts = [] + } + , _hash = MkBlake2b255Hex "af6366838cfac9cc56856ffe1d595ad1dd32c9bafb1ca064a08b5c687293110f" + } + +-- Source: https://docs.rs/utxorpc-spec/latest/utxorpc_spec/utxorpc/v1alpha/cardano/struct.Tx.html +data Tx = MkTx + { _inputs :: [TxInput] + , _outputs :: [TxOutput] + , _certificates :: [Aeson.Value] + , _withdrawals :: [Aeson.Value] + , _mint :: [Aeson.Value] + , _reference_inputs :: [Aeson.Value] + , _witnesses :: TxWitnesses + , collateral :: TxCollateral + , _fee :: Integer + , _validity :: TxValidity + , _successful :: Bool + , _auxiliary :: TxAuxiliary + , _hash :: Hash32 + } + deriving stock (Generic) + deriving (Aeson.ToJSON) via (WithoutUnderscore Tx) + deriving (Aeson.FromJSON) via (WithoutUnderscore Tx) +makeLenses ''Tx +makeLensesFor [("collateral", "txCollateral")] ''Tx + +-- PlutusData (JSON representation) and other serialisations + +encodePlutusData :: PlutusLedgerApi.V1.Data -> PlutusData +encodePlutusData = MkPlutusData . datumToJson + +datumToJson :: PlutusLedgerApi.V1.Data -> Aeson.Value +{-# NOINLINE datumToJson #-} +datumToJson = + \case + PlutusLedgerApi.V1.Constr n fields -> + Aeson.object + [ "constr" + .= Aeson.object + [ "tag" .= Aeson.Number (fromInteger n) + , "any_constructor" .= Aeson.Number 0 + , "fields" + .= Aeson.Array + (Vec.fromList $ datumToJson <$> fields) + ] + ] + PlutusLedgerApi.V1.Map kvs -> + Aeson.object + [ "map" + .= Aeson.object + [ "pairs" + .= Aeson.Array + ( Vec.fromList $ + kvs <&> \(k, v) -> + Aeson.object + [ "key" .= datumToJson k + , "value" .= datumToJson v + ] + ) + ] + ] + PlutusLedgerApi.V1.I n -> + Aeson.object + [ "big_int" + .= Aeson.object + [ "big_n_int" + .= Aeson.String + ( B64.extractBase64 $ + B64.encodeBase64 $ + BS.pack $ + fromInteger + <$> digits @Integer @Double 16 n + ) + ] + ] + PlutusLedgerApi.V1.B bs -> + Aeson.object + [ "bounded_bytes" + .= Aeson.String + ( B64.extractBase64 $ + B64.encodeBase64 bs + ) + ] + PlutusLedgerApi.V1.List xs -> + Aeson.object + [ "array" + .= Aeson.object + [ "items" .= Aeson.Array (datumToJson <$> Vec.fromList xs) + ] + ] + +digits :: forall n m. (Integral n, RealFrac m, Floating m) => n -> n -> [n] +digits base n = + fst <$> case reverse [0 .. totalDigits @n @m base n - 1] of + (i : is) -> + scanl + (\(_, remainder) digit -> remainder `divMod` (base ^ digit)) + (n `divMod` (base ^ i)) + is + [] -> [] + +totalDigits :: forall n m. (Integral n, RealFrac m, Floating m) => n -> n -> n +totalDigits base = round @m . logBase (fromIntegral base) . fromIntegral + +serialisePubKeyHash :: PlutusLedgerApi.V1.PubKeyHash -> Hash28 +serialisePubKeyHash = MkBlake2b244Hex . serialiseAsHex . PlutusLedgerApi.V1.getPubKeyHash + +serialiseCurrencySymbol :: PlutusLedgerApi.V1.CurrencySymbol -> Hash28 +serialiseCurrencySymbol = MkBlake2b244Hex . serialiseAsHex . PlutusLedgerApi.V1.unCurrencySymbol + +serialiseScriptHash :: PlutusLedgerApi.V1.ScriptHash -> Hash28 +serialiseScriptHash = MkBlake2b244Hex . serialiseAsHex . PlutusLedgerApi.V1.getScriptHash + +serialiseTxHash :: PlutusLedgerApi.V1.TxId -> Hash32 +serialiseTxHash = MkBlake2b255Hex . serialiseAsHex . PlutusLedgerApi.V1.getTxId + +serialiseAsHex :: PlutusLedgerApi.V1.BuiltinByteString -> T.Text +serialiseAsHex = + B16.extractBase16 + . B16.encodeBase16 + . PlutusLedgerApi.V1.fromBuiltin + +plutusAddressToOuraAddress :: (HasCallStack) => PlutusLedgerApi.V1.Address -> Address +plutusAddressToOuraAddress = + MkAddressAsBase64 + . B64.extractBase64 + . B64.encodeBase64 + . SerialiseRaw.serialiseToRawBytes + . either error id + . Address.plutusAddressToShelleyAddress Ledger.Mainnet + +-------------------------------------------------------------------------------- +-- CEM (cardano-api) -> Tx + +-- For testing: build a tx in the Oura format from a Cardano tx. +-- We populate only fields we use, use with cautious. +resolvedTxToOura :: C.TxBodyContent C.BuildTx Era -> UTxO Era -> Tx +resolvedTxToOura tbc utxo = + arbitraryTx + { _inputs = oInputs + , _outputs = oOutputs + } + where + oInputs = mapMaybe (toOuraInput utxo . fst) (C.txIns tbc) + oOutputs = toOuraTxOutput <$> C.txOuts tbc + +-- | This is a partial function, use with cautious +toOuraInput :: UTxO Era -> TxIn -> Maybe TxInput +toOuraInput (C.UTxO utxo) txIn = + case Map.lookup txIn utxo of + Nothing -> Nothing + Just output -> + pure $ + MkTxInput + { _tx_hash = MkBlake2b255Hex "" + , _output_index = 0 + , _as_output = toOuraTxOutput output + , _redeemer = Nothing + } + +-- | This is a partial function, we use address and datum +toOuraTxOutput :: C.TxOut ctx Era -> TxOutput +toOuraTxOutput (C.TxOut addr _ dat _) = + MkTxOutput + { _address = toOuraAddrress addr + , _coin = 0 + , _assets = [] + , _datum = toOuraDatum dat + , _script = Nothing + } + +-- | This is a partial function, we use only original_cbor. +toOuraDatum :: C.TxOutDatum ctx Era -> Maybe Datum +toOuraDatum = \case + (C.TxOutDatumInline _ hsd) -> + let bs = C.serialiseToCBOR hsd + in Just $ + MkDatum + { _payload = MkPlutusData Aeson.Null + , hash = MkBlake2b255Hex "" + , _original_cbor = + B16.extractBase16 $ B16.encodeBase16 bs + -- Base64.extractBase64 $ Base64.encodeBase64 bs + } + _ -> Nothing + +toOuraAddrress :: C.AddressInEra Era -> Address +toOuraAddrress (C.AddressInEra _ addr) = + case addr of + C.ByronAddress _ -> error "Encounter Byron address" + C.ShelleyAddress {} -> + addr + & MkAddressAsBase64 + -- TODO: switch to base64, see https://github.com/mlabs-haskell/cem-script/issues/107 + -- . Base64.extractBase64 + -- . Base64.encodeBase64 + . B16.extractBase16 + . B16.encodeBase16 + . SerialiseRaw.serialiseToRawBytes diff --git a/test/Auction.hs b/test/Auction.hs index c43d122..d10ae61 100644 --- a/test/Auction.hs +++ b/test/Auction.hs @@ -8,11 +8,12 @@ import Cardano.Api.NetworkId (toShelleyNetwork) import Cardano.CEM import Cardano.CEM.Examples.Auction import Cardano.CEM.Examples.Compilation () +import Cardano.CEM.Indexing.Event +import Cardano.CEM.Indexing.Tx (resolvedTxToOura) import Cardano.CEM.Monads import Cardano.CEM.OffChain import Cardano.Extras import Control.Monad.Trans (MonadIO (..)) -import OuraFilters.Mock (IndexerEvent (Following, Initial), extractEvent, resolvedTxToOura) import PlutusLedgerApi.V1.Value (assetClassValue) import Test.Hspec (describe, it, shouldBe) import TestNFT (testNftAssetClass) diff --git a/test/Main.hs b/test/Main.hs index 83d6b58..be00a5f 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -10,7 +10,7 @@ import Auction (auctionSpec) import Data.Maybe (isJust) import Dynamic (dynamicSpec) import OffChain (offChainSpec) -import OuraFilters (ouraFiltersSpec) +import OuraFilters.Simple (simpleSpec) import System.Environment (lookupEnv) import Utils (clearLogs) import Voting (votingSpec) @@ -20,12 +20,12 @@ main = do runIndexing <- isJust <$> lookupEnv "INDEXING_TEST" hspec do auctionSpec - -- votingSpec - -- offChainSpec - -- dynamicSpec + votingSpec + offChainSpec + dynamicSpec if runIndexing then do -- These tests are not currently supported on CI runIO clearLogs - ouraFiltersSpec + simpleSpec else pure mempty diff --git a/test/Oura.hs b/test/Oura.hs deleted file mode 100644 index 32562ab..0000000 --- a/test/Oura.hs +++ /dev/null @@ -1,117 +0,0 @@ -{- TODO: move to the Indexing folder? -} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE OverloadedRecordDot #-} - -module Oura ( - WorkDir (MkWorkDir, unWorkDir), - Oura (MkOura, send, receive, shutDown), - withOura, - runOura, -) where - -import Prelude - -import Cardano.CEM.Indexing qualified as Indexing -import Control.Concurrent (threadDelay) -import Control.Concurrent.Async (Async) -import Control.Concurrent.Async qualified as Async -import Control.Monad (void) -import Control.Monad.Cont (ContT (ContT, runContT)) -import Control.Monad.Trans (lift) -import Data.ByteString qualified as BS -import Data.String (IsString (fromString)) -import Data.Text qualified as T -import Data.Text.IO qualified as T.IO -import Oura.Communication qualified as Communication -import System.Directory (removeFile) -import System.Process qualified as Process -import Toml (Table) -import Utils (withNewFile) -import Utils qualified - -{- | A time required for oura to start up and create a socket, -in microseconds. --} -ouraStartupDurationNs :: Int -ouraStartupDurationNs = 1_000_000 - -data Oura m = MkOura - { send :: BS.ByteString -> m () - , receive :: m BS.ByteString - , shutDown :: m () - } -newtype WorkDir = MkWorkDir {unWorkDir :: T.Text} - deriving newtype (IsString) - -withOura :: - WorkDir -> - Utils.SpotGarbage IO Process.ProcessHandle -> - (Indexing.SourcePath -> Indexing.SinkPath -> Table) -> - (Oura IO -> IO r) -> - IO r -withOura spotHandle workdir makeConfig = - runContT $ runOura spotHandle workdir makeConfig $ Just $ Communication.MkIntervalMs 1_000 - -runOura :: - WorkDir -> - Utils.SpotGarbage IO Process.ProcessHandle -> - (Indexing.SourcePath -> Indexing.SinkPath -> Table) -> - Maybe Communication.Interval -> - ContT r IO (Oura IO) -runOura (MkWorkDir (T.unpack -> workdir)) spotHandle makeConfig outputCheckingInterval = do - writerPath <- - ContT $ - withNewFile "writer.socket" workdir - sinkPath :: Indexing.SinkPath <- - fmap fromString $ - ContT $ - withNewFile "sink.socket" workdir - sourcePath :: Indexing.SourcePath <- - fmap fromString $ - ContT $ - withNewFile "source.socket" workdir - lift $ removeFile $ T.unpack $ Indexing.unSourcePath sourcePath - let - config = Indexing.configToText $ makeConfig sourcePath sinkPath - configPath <- ContT $ withNewFile "Indexing.toml" workdir - lift $ T.IO.writeFile configPath config - (ouraHandle, waitingForClose) <- launchOura configPath spotHandle - lift $ Async.link waitingForClose - lift $ threadDelay ouraStartupDurationNs - ouraConnection <- - lift $ - Communication.connectToDaemon writerPath sourcePath - ouraOutput <- - lift $ - Communication.listenOuraSink sinkPath outputCheckingInterval - let - shutDown = do - Communication.stopMonitoring ouraOutput - Communication.close ouraConnection - Async.cancel waitingForClose - Process.terminateProcess ouraHandle - receive = Communication.waitForOutput ouraOutput - send = void . Communication.sendToOura ouraConnection - pure MkOura {shutDown, receive, send} - -launchOura :: - FilePath -> - Utils.SpotGarbage IO Process.ProcessHandle -> - ContT r IO (Process.ProcessHandle, Async ()) -launchOura configPath spotHandle = do - ouraHandle <- lift do - ouraHandle <- - Process.spawnProcess - "oura" - [ "daemon" - , "--config" - , configPath - ] - - void $ spotHandle.run ouraHandle - pure ouraHandle - - waitingForClose <- ContT $ Async.withAsync $ do - _ <- Process.waitForProcess ouraHandle - error "Oura process has stopped." - pure (ouraHandle, waitingForClose) diff --git a/test/Oura/Communication.hs b/test/Oura/Communication.hs index 914dcf3..e24f374 100644 --- a/test/Oura/Communication.hs +++ b/test/Oura/Communication.hs @@ -1,6 +1,14 @@ {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Use fewer imports" #-} module Oura.Communication ( + WorkDir (MkWorkDir, unWorkDir), + Oura (MkOura, send, receive, shutDown), + withOura, + runOura, connectToDaemon, sendToOura, close, @@ -31,9 +39,115 @@ import Data.Traversable (for) import Network.Socket qualified as Socket import Network.Socket.ByteString qualified as Socket.BS -import Cardano.CEM.Indexing (SinkPath, SourcePath (MkSourcePath), unSinkPath) +import Prelude + +import Cardano.CEM.Indexing.Oura qualified as Indexing +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (Async) +import Control.Concurrent.Async qualified as Async +import Control.Monad (void) +import Control.Monad.Cont (ContT (ContT, runContT)) +import Control.Monad.Trans (lift) +import Data.ByteString qualified as BS +import Data.String (IsString (fromString)) +import Data.Text qualified as T +import Data.Text.IO qualified as T.IO +import System.Directory (removeFile) +import System.Process qualified as Process +import Toml (Table) +import Utils (withNewFile) +import Utils qualified + +import Cardano.CEM.Indexing.Oura (SinkPath, SourcePath (MkSourcePath), unSinkPath) import Data.ByteString.Char8 qualified as BS.Char8 +{- | A time required for oura to start up and create a socket, +in microseconds. +-} +ouraStartupDurationNs :: Int +ouraStartupDurationNs = 1_000_000 + +data Oura m = MkOura + { send :: BS.ByteString -> m () + , receive :: m BS.ByteString + , shutDown :: m () + } +newtype WorkDir = MkWorkDir {unWorkDir :: T.Text} + deriving newtype (IsString) + +withOura :: + WorkDir -> + Utils.SpotGarbage IO Process.ProcessHandle -> + (Indexing.SourcePath -> Indexing.SinkPath -> Table) -> + (Oura IO -> IO r) -> + IO r +withOura spotHandle workdir makeConfig = + runContT $ runOura spotHandle workdir makeConfig $ Just $ MkIntervalMs 1_000 + +runOura :: + WorkDir -> + Utils.SpotGarbage IO Process.ProcessHandle -> + (Indexing.SourcePath -> Indexing.SinkPath -> Table) -> + Maybe Interval -> + ContT r IO (Oura IO) +runOura (MkWorkDir (T.unpack -> workdir)) spotHandle makeConfig outputCheckingInterval = do + writerPath <- + ContT $ + withNewFile "writer.socket" workdir + sinkPath :: Indexing.SinkPath <- + fmap fromString $ + ContT $ + withNewFile "sink.socket" workdir + sourcePath :: Indexing.SourcePath <- + fmap fromString $ + ContT $ + withNewFile "source.socket" workdir + lift $ removeFile $ T.unpack $ Indexing.unSourcePath sourcePath + let + config = Indexing.configToText $ makeConfig sourcePath sinkPath + configPath <- ContT $ withNewFile "Indexing.toml" workdir + lift $ T.IO.writeFile configPath config + (ouraHandle, waitingForClose) <- launchOura configPath spotHandle + lift $ Async.link waitingForClose + lift $ threadDelay ouraStartupDurationNs + ouraConnection <- + lift $ + connectToDaemon writerPath sourcePath + ouraOutput <- + lift $ + listenOuraSink sinkPath outputCheckingInterval + let + shutDown = do + stopMonitoring ouraOutput + close ouraConnection + Async.cancel waitingForClose + Process.terminateProcess ouraHandle + receive = waitForOutput ouraOutput + send = void . sendToOura ouraConnection + pure MkOura {shutDown, receive, send} + +launchOura :: + FilePath -> + Utils.SpotGarbage IO Process.ProcessHandle -> + ContT r IO (Process.ProcessHandle, Async ()) +launchOura configPath spotHandle = do + ouraHandle <- lift do + ouraHandle <- + Process.spawnProcess + "oura" + [ "daemon" + , "--config" + , configPath + ] + + void $ spotHandle.run ouraHandle + pure ouraHandle + + waitingForClose <- ContT $ Async.withAsync $ do + _ <- Process.waitForProcess ouraHandle + error "Oura process has stopped." + pure (ouraHandle, waitingForClose) + data OuraDaemonConnection = MkOuraDaemonConnection { ownSocket :: Socket.Socket , ouraAddress :: Socket.SockAddr diff --git a/test/Oura/Config.hs b/test/Oura/Config.hs deleted file mode 100644 index 050542a..0000000 --- a/test/Oura/Config.hs +++ /dev/null @@ -1,83 +0,0 @@ -{- FIXME: remove -} -{-# LANGUAGE BlockArguments #-} - -module Oura.Config ( --- filtersL, --- predicateL, --- tableL, --- atKey, --- _Table, --- _Integer, --- _Bool, --- _Text, - -) where - --- import Prelude - --- import Cardano.CEM.Indexing qualified as Config --- import Control.Lens ( --- At (at), --- Each (each), --- Iso', --- Lens', --- Prism', --- Traversal', --- from, --- iso, --- mapping, --- partsOf, --- prism', --- _Just, --- ) --- import Data.Map (Map) --- import Data.Text qualified as T --- import Toml qualified - --- -- * Config - --- filterL :: Iso' Config.Filter Toml.Table --- filterL = iso Config.unFilter Config.MkFilter - --- predicateL :: Traversal' Config.Filter T.Text --- predicateL = filterL . atKey "predicate" . _Just . _Text - --- filtersL :: Traversal' Toml.Table [Config.Filter] --- filtersL = --- atKey "filters" --- . _Just --- . _List --- . partsOf (each . _Table . from filterL) - --- atKey :: T.Text -> Traversal' Toml.Table (Maybe Toml.Value) --- atKey key = tableL . at key - --- tableL :: Lens' Toml.Table (Map T.Text Toml.Value) --- tableL = --- iso (\(Toml.MkTable t) -> t) Toml.MkTable --- . mapping (iso snd ((),)) - --- _Table :: Prism' Toml.Value Toml.Table --- _Table = prism' Toml.Table \case --- Toml.Table table -> Just table --- _ -> Nothing - --- _Text :: Prism' Toml.Value T.Text --- _Text = prism' Toml.Text \case --- Toml.Text t -> Just t --- _ -> Nothing - --- _List :: Prism' Toml.Value [Toml.Value] --- _List = prism' Toml.List \case --- Toml.List xs -> Just xs --- _ -> Nothing - --- _Bool :: Prism' Toml.Value Bool --- _Bool = prism' Toml.Bool \case --- Toml.Bool b -> Just b --- _ -> Nothing - --- _Integer :: Prism' Toml.Value Integer --- _Integer = prism' Toml.Integer \case --- Toml.Integer n -> Just n --- _ -> Nothing diff --git a/test/OuraFilters/Auction.hs b/test/OuraFilters/Auction.hs index e47259a..933aa55 100644 --- a/test/OuraFilters/Auction.hs +++ b/test/OuraFilters/Auction.hs @@ -5,7 +5,8 @@ module OuraFilters.Auction (spec) where import Cardano.CEM.Examples.Auction qualified as Auction import Cardano.CEM.Examples.Compilation () -import Cardano.CEM.Indexing qualified as OuraConfig +import Cardano.CEM.Indexing.Oura qualified as OuraConfig +import Cardano.CEM.Indexing.Tx qualified as Tx import Cardano.CEM.OnChain qualified as Compiled import Cardano.Ledger.BaseTypes qualified as Ledger import Control.Lens ((%~), (.~)) @@ -16,7 +17,7 @@ import Data.Aeson.Types qualified as Aeson.Types import Data.ByteString qualified as BS import Data.Data (Proxy (Proxy)) import Data.Text qualified as T -import Oura qualified +import Oura.Communication qualified as Oura import OuraFilters.Mock qualified as Mock import Plutus.Extras (scriptValidatorHash) import PlutusLedgerApi.V1 qualified @@ -42,20 +43,20 @@ spec = arbitraryStakeCredential = PlutusLedgerApi.V1.StakingPtr 5 3 2 rightTxHash = - Mock.MkBlake2b255Hex + Tx.MkBlake2b255Hex "2266778888888888888888888888888888888888888888888888444444444444" inputFromValidator = emptyInputFixture auctionPaymentCredential (Just arbitraryStakeCredential) tx = Mock.txToBS . Mock.mkTxEvent - . (Mock.inputs %~ (inputFromValidator :)) - . (Mock.hash .~ rightTxHash) - $ Mock.arbitraryTx + . (Tx.inputs %~ (inputFromValidator :)) + . (Tx.hash .~ rightTxHash) + $ Tx.arbitraryTx unmatchingTx = Mock.txToBS . Mock.mkTxEvent - $ Mock.arbitraryTx + $ Tx.arbitraryTx makeConfig source sink = either error id $ OuraConfig.ouraMonitoringScript (Proxy @Auction.SimpleAuction) Ledger.Mainnet source sink @@ -73,28 +74,28 @@ spec = oura.send tx msg <- oura.receive txHash <- either error pure $ extractTxHash msg - Mock.MkBlake2b255Hex txHash `shouldBe` rightTxHash + Tx.MkBlake2b255Hex txHash `shouldBe` rightTxHash oura.shutDown emptyInputFixture :: PlutusLedgerApi.V1.Credential -> Maybe PlutusLedgerApi.V1.StakingCredential -> - Mock.TxInput + Tx.TxInput emptyInputFixture paymentCred mstakeCred = - Mock.MkTxInput - { Mock._as_output = - Mock.MkTxOutput - { Mock._address = - Mock.plutusAddressToOuraAddress $ + Tx.MkTxInput + { Tx._as_output = + Tx.MkTxOutput + { Tx._address = + Tx.plutusAddressToOuraAddress $ PlutusLedgerApi.V1.Address paymentCred mstakeCred - , Mock._datum = Nothing - , Mock._coin = 2 - , Mock._script = Nothing - , Mock._assets = mempty + , Tx._datum = Nothing + , Tx._coin = 2 + , Tx._script = Nothing + , Tx._assets = mempty } - , Mock._tx_hash = Mock.MkBlake2b255Hex "af6366838cfac9cc56856ffe1d595ad1dd32c9bafb1ca064a08b5c687293110f" - , Mock._output_index = 0 - , Mock._redeemer = Nothing + , Tx._tx_hash = Tx.MkBlake2b255Hex "af6366838cfac9cc56856ffe1d595ad1dd32c9bafb1ca064a08b5c687293110f" + , Tx._output_index = 0 + , Tx._redeemer = Nothing } extractTxHash :: BS.ByteString -> Either String T.Text diff --git a/test/OuraFilters/Mock.hs b/test/OuraFilters/Mock.hs index b9300a6..67b2e37 100644 --- a/test/OuraFilters/Mock.hs +++ b/test/OuraFilters/Mock.hs @@ -6,470 +6,14 @@ module OuraFilters.Mock where -import Cardano.Api qualified as C - --- import Cardano.Api.Address qualified as C -import Cardano.Api (TxIn, UTxO) -import Cardano.Api.Address qualified as C (Address (..)) -import Cardano.Api.ScriptData qualified as C -import Cardano.Api.SerialiseRaw qualified as SerialiseRaw -import Cardano.CEM (CEMScript, CEMScriptDatum, State, Transition, transitionStage) -import Cardano.CEM.Address qualified as Address -import Cardano.CEM.OnChain (CEMScriptCompiled, CEMScriptIsData) -import Cardano.Extras (Era) -import Cardano.Ledger.BaseTypes qualified as Ledger -import Control.Lens (view, (^.)) -import Control.Lens.TH (makeLenses, makeLensesFor) -import Control.Monad ((<=<)) -import Data.Aeson (KeyValue ((.=))) +import Cardano.CEM.Indexing.Tx (Tx, WithoutUnderscore (..)) +import Control.Lens.TH (makeLenses) import Data.Aeson qualified as Aeson -import Data.Base16.Types qualified as Base16 -import Data.Base16.Types qualified as Base16.Types -import Data.Base64.Types qualified as Base64 -import Data.Base64.Types qualified as Base64.Types -import Data.Bifunctor (first) import Data.ByteString qualified as BS -import Data.ByteString.Base16 qualified as Base16 -import Data.ByteString.Base64 qualified as Base64 import Data.ByteString.Lazy qualified as LBS -import Data.Data (Proxy (Proxy)) -import Data.Either.Extra (eitherToMaybe) -import Data.Function ((&)) -import Data.Functor ((<&>)) -import Data.List (find) -import Data.Map.Strict qualified as Map -import Data.Maybe (fromJust, mapMaybe) -import Data.Spine (Spine, getSpine) -import Data.Text qualified as T -import Data.Text.Encoding (encodeUtf8) -import Data.Tuple (swap) -import Data.Vector qualified as Vec -import GHC.Generics (Generic (Rep)) -import GHC.Stack.Types (HasCallStack) -import PlutusLedgerApi.V1 (FromData) -import PlutusLedgerApi.V1 qualified -import Safe qualified -import Utils (digits) +import GHC.Generics (Generic) import Prelude -newtype WithoutUnderscore a = MkWithoutUnderscore a - deriving newtype (Generic) - -withoutLeadingUnderscore :: Aeson.Options -withoutLeadingUnderscore = - Aeson.defaultOptions - { Aeson.fieldLabelModifier = \case - '_' : fieldName -> fieldName - fieldName -> fieldName - } -instance - ( Generic a - , Aeson.GToJSON' Aeson.Value Aeson.Zero (GHC.Generics.Rep a) - ) => - Aeson.ToJSON (WithoutUnderscore a) - where - toJSON = Aeson.genericToJSON withoutLeadingUnderscore - -instance (Generic a, Aeson.GFromJSON Aeson.Zero (Rep a)) => Aeson.FromJSON (WithoutUnderscore a) where - parseJSON = Aeson.genericParseJSON withoutLeadingUnderscore - -newtype Address = MkAddressAsBase64 {_addressL :: T.Text} - deriving newtype (Show, Eq, Ord, Aeson.ToJSON, Aeson.FromJSON) -makeLenses ''Address - --- 32B long -newtype Hash32 = MkBlake2b255Hex {unHash32 :: T.Text} - deriving newtype (Show, Eq, Ord) - deriving newtype (Aeson.ToJSON) - deriving newtype (Aeson.FromJSON) -makeLenses ''Hash32 - --- 28B long -newtype Hash28 = MkBlake2b244Hex {unHash28 :: T.Text} - deriving newtype (Show, Eq, Ord) - deriving newtype (Aeson.ToJSON) - deriving newtype (Aeson.FromJSON) -makeLenses ''Hash28 - -data Asset = MkAsset - { _name :: T.Text - , _output_coin :: Integer -- positive - , _mint_coin :: Integer - } - deriving stock (Generic) - deriving (Aeson.ToJSON) via (WithoutUnderscore Asset) - deriving (Aeson.FromJSON) via (WithoutUnderscore Asset) -makeLenses ''Asset - -data Multiasset = MkMultiasset - { _policy_id :: Hash28 - , assets :: [Asset] - } - deriving stock (Generic) - deriving (Aeson.ToJSON) via (WithoutUnderscore Multiasset) - deriving (Aeson.FromJSON) via (WithoutUnderscore Multiasset) -makeLenses ''Multiasset -makeLensesFor - [ ("assets", "multiassetAssets") - -- , ("redeemer", "multiassetRedeemer") - ] - ''Multiasset - -newtype PlutusData = MkPlutusData {_plutusData :: Aeson.Value} - deriving newtype (Generic) - deriving newtype (Aeson.FromJSON, Aeson.ToJSON) -makeLenses ''PlutusData - -data Purpose - = PURPOSE_UNSPECIFIED - | PURPOSE_SPEND - | PURPOSE_MINT - | PURPOSE_CERT - | PURPOSE_REWARD - deriving stock (Show, Enum, Bounded) - -instance Aeson.FromJSON Purpose where - parseJSON = - maybe (fail "There is no Purpose case with this Id") pure - . Safe.toEnumMay - <=< Aeson.parseJSON @Int - -instance Aeson.ToJSON Purpose where - toJSON = Aeson.toJSON @Int . fromEnum - -data Datum = MkDatum - { hash :: Hash32 - , _payload :: PlutusData - , _original_cbor :: T.Text - } - deriving stock (Generic) - deriving (Aeson.ToJSON) via (WithoutUnderscore Datum) - deriving (Aeson.FromJSON) via (WithoutUnderscore Datum) -makeLenses ''Datum -makeLensesFor [("hash", "datumHash")] ''Datum - -data Redeemer = MkRedeemer - { _purpose :: Purpose - , payload :: PlutusData - } - deriving stock (Generic) - deriving (Aeson.ToJSON) via (WithoutUnderscore Redeemer) - deriving (Aeson.FromJSON) via (WithoutUnderscore Redeemer) -makeLenses ''Redeemer -makeLensesFor [("payload", "redeemerPayload")] ''Redeemer - -data TxOutput = MkTxOutput - { _address :: Address - , _coin :: Integer - , _assets :: [Multiasset] - , _datum :: Maybe Datum - , _script :: Maybe Aeson.Value - } - deriving stock (Generic) - deriving (Aeson.ToJSON) via (WithoutUnderscore TxOutput) - deriving (Aeson.FromJSON) via (WithoutUnderscore TxOutput) -makeLenses ''TxOutput - -data TxInput = MkTxInput - { _tx_hash :: Hash32 - , _output_index :: Integer - , _as_output :: TxOutput - , _redeemer :: Maybe Redeemer - } - deriving stock (Generic) - deriving (Aeson.ToJSON) via (WithoutUnderscore TxInput) - deriving (Aeson.FromJSON) via (WithoutUnderscore TxInput) -makeLenses ''TxInput - -data TxWitnesses = MkTxWitnesses - { _vkeywitness :: [Aeson.Value] - , script :: [Aeson.Value] - , _plutus_datums :: [Aeson.Value] - } - deriving stock (Generic) - deriving (Aeson.ToJSON) via (WithoutUnderscore TxWitnesses) - deriving (Aeson.FromJSON) via (WithoutUnderscore TxWitnesses) - -makeLenses ''TxWitnesses -makeLensesFor [("script", "txWitnessesScript")] ''Multiasset - -data TxCollateral = MkTxCollateral - { _collateral :: [Aeson.Value] - , _collateral_return :: TxOutput - , _total_collateral :: Integer - } - deriving stock (Generic) - deriving (Aeson.ToJSON) via (WithoutUnderscore TxCollateral) - deriving (Aeson.FromJSON) via (WithoutUnderscore TxCollateral) -makeLenses ''TxCollateral - -data TxValidity = MkTxValidity - { _start :: Integer - , _ttl :: Integer - } - deriving stock (Generic) - deriving (Aeson.ToJSON) via (WithoutUnderscore TxValidity) - deriving (Aeson.FromJSON) via (WithoutUnderscore TxValidity) -makeLenses ''TxValidity - -data TxAuxiliary = MkTxAuxiliary - { _metadata :: [Aeson.Value] - , _scripts :: [Aeson.Value] - } - deriving stock (Generic) - deriving (Aeson.ToJSON) via (WithoutUnderscore TxAuxiliary) - deriving (Aeson.FromJSON) via (WithoutUnderscore TxAuxiliary) -makeLenses ''TxAuxiliary - -arbitraryTx :: Tx -arbitraryTx = - MkTx - { _inputs = [] - , _outputs = [] - , _certificates = [] - , _withdrawals = [] - , _mint = [] - , _reference_inputs = [] - , _witnesses = - MkTxWitnesses - { _vkeywitness = [] - , script = [] - , _plutus_datums = [] - } - , collateral = - MkTxCollateral - { _collateral = [] - , _collateral_return = - MkTxOutput - { _address = MkAddressAsBase64 "cM+tGRS1mdGL/9FNK71pYBnCiZy91qAzJc32gLw=" - , _coin = 0 - , _assets = [] - , _datum = Nothing - , _script = Nothing - } - , _total_collateral = 0 - } - , _fee = 0 - , _validity = - MkTxValidity - { _start = 0 - , _ttl = 0 - } - , _successful = True - , _auxiliary = - MkTxAuxiliary - { _metadata = [] - , _scripts = [] - } - , _hash = MkBlake2b255Hex "af6366838cfac9cc56856ffe1d595ad1dd32c9bafb1ca064a08b5c687293110f" - } - --- Source: https://docs.rs/utxorpc-spec/latest/utxorpc_spec/utxorpc/v1alpha/cardano/struct.Tx.html -data Tx = MkTx - { _inputs :: [TxInput] - , _outputs :: [TxOutput] - , _certificates :: [Aeson.Value] - , _withdrawals :: [Aeson.Value] - , _mint :: [Aeson.Value] - , _reference_inputs :: [Aeson.Value] - , _witnesses :: TxWitnesses - , collateral :: TxCollateral - , _fee :: Integer - , _validity :: TxValidity - , _successful :: Bool - , _auxiliary :: TxAuxiliary - , _hash :: Hash32 - } - deriving stock (Generic) - deriving (Aeson.ToJSON) via (WithoutUnderscore Tx) - deriving (Aeson.FromJSON) via (WithoutUnderscore Tx) -makeLenses ''Tx -makeLensesFor [("collateral", "txCollateral")] ''Tx - --- --- - -{- | Indexer events. - We extract events from transactions, where we can encounter three situations: - - (1) For the very first transition there is only target datum and no redeemer. - In that case we can only restore the name of the transition, - i.e. 'Spine Transition' - - (2) For intermidiate transitions we have both datums that identify them and - additionally redeemer, that contains the whole transition. In that case - we can restore the whole transition. - - (3) For the final transition the situation is like (2) except the target - datum is missing, which doesn't matter. - - - TODO: How we can improve this in the future: - * API is probably bad, as we always have some transition like Init state - - which you can decode, as you have State. If one changes data - `CEMAction script = MkCEMAction (Params script) (Transition script)` to - `... = Init (Params script) (State script) - | Transition (Params script) (Transition script)` - one could reuse this datatype in all situations. --} -data IndexerEvent script - = Initial (Spine (Transition script)) - | -- | FIXME: Migrate from (Spine (Transition script)) to (Transition script) - -- | FIXME: Open an issue in Oura's repository - Following (Spine (Transition script)) -- (Transition script) - -deriving stock instance - (Show (Spine (Transition script))) => - (Show (IndexerEvent script)) -deriving stock instance - (Eq (Spine (Transition script))) => - (Eq (IndexerEvent script)) - --- For testing: build a tx in the Oura format from a Cardano tx. --- We populate only fields we use, use with cautious. -resolvedTxToOura :: C.TxBodyContent C.BuildTx Era -> UTxO Era -> Tx -resolvedTxToOura tbc utxo = - arbitraryTx - { _inputs = oInputs - , _outputs = oOutputs - } - where - oInputs = mapMaybe (toOuraInput utxo . fst) (C.txIns tbc) - oOutputs = toOuraTxOutput <$> C.txOuts tbc - --- | This is a partial function, use with cautious -toOuraInput :: UTxO Era -> TxIn -> Maybe TxInput -toOuraInput (C.UTxO utxo) txIn = - case Map.lookup txIn utxo of - Nothing -> Nothing - Just output -> - pure $ - MkTxInput - { _tx_hash = MkBlake2b255Hex "" - , _output_index = 0 - , _as_output = toOuraTxOutput output - , _redeemer = Nothing - } - --- | This is a partial function, we use address and datum -toOuraTxOutput :: C.TxOut ctx Era -> TxOutput -toOuraTxOutput (C.TxOut addr _ dat _) = - MkTxOutput - { _address = toOuraAddrress addr - , _coin = 0 - , _assets = [] - , _datum = toOuraDatum dat - , _script = Nothing - } - --- | This is a partial function, we use only original_cbor. -toOuraDatum :: C.TxOutDatum ctx Era -> Maybe Datum -toOuraDatum = \case - (C.TxOutDatumInline _ hsd) -> - let bs = C.serialiseToCBOR hsd - in Just $ - MkDatum - { _payload = MkPlutusData Aeson.Null - , hash = MkBlake2b255Hex "" - , _original_cbor -- Base64.extractBase64 $ Base64.encodeBase64 $ - = - Base16.extractBase16 $ Base16.encodeBase16 bs - } - _ -> Nothing - -toOuraAddrress :: C.AddressInEra Era -> Address -toOuraAddrress (C.AddressInEra _ addr) = - case addr of - C.ByronAddress _ -> error "Encounter Byron address" - C.ShelleyAddress {} -> - addr - & MkAddressAsBase64 - -- . Base64.extractBase64 - -- . Base64.encodeBase64 - . Base16.extractBase16 - . Base16.encodeBase16 - . SerialiseRaw.serialiseToRawBytes - -{- | The core function, that extracts an Event out of a Oura transaction. -It might be a pure function, IO here was used mostly to simplify debugging -during its development. --} -extractEvent :: - forall script. - ( CEMScript script - , CEMScriptIsData script - , CEMScriptCompiled script - ) => - Ledger.Network -> - Tx -> - IO (Maybe (IndexerEvent script)) -extractEvent network tx = do - -- Script payemnt credential based predicate - let (Right scriptAddr) = Address.scriptCardanoAddress (Proxy @script) network - let cPred = hasAddr scriptAddr - - -- Source state - let mOwnInput :: Maybe TxInput = find (cPred . view as_output) (tx ^. inputs) - let mSourceState :: Maybe (State script) = (extractState . view as_output) =<< mOwnInput - let mSourceSpine :: Maybe (Spine (State script)) = getSpine <$> mSourceState - - -- Target state - let mOwnOutput :: Maybe TxOutput = find cPred $ tx ^. outputs - let mTargetState :: Maybe (State script) = extractState =<< mOwnOutput - let mTargetSpine :: Maybe (Spine (State script)) = getSpine <$> mTargetState - - -- Look up the transition - let transitions = - first - (\(_, b, c) -> (b, c)) - . swap - <$> Map.toList (transitionStage $ Proxy @script) - let transSpine = lookup (mSourceSpine, mTargetSpine) transitions - - -- Return - case mOwnInput of - Nothing -> pure $ Initial <$> transSpine - Just _ownInput -> do - -- FIXME: fix once Oura has rawCbor for redeemer - -- rdm <- ownInput ^. redeemer - -- pure $ Following $ undefined (rdm ^. redeemerPayload) - pure $ Following <$> transSpine - -extractState :: - forall script. - (FromData (CEMScriptDatum script)) => - TxOutput -> - Maybe (State script) -extractState MkTxOutput {_datum = mDtm} = - case mDtm of - Nothing -> Nothing - Just dtm -> do - let MkDatum _ _ cbor = dtm - let datumAsData :: PlutusLedgerApi.V1.Data = - cbor - & C.toPlutusData - . C.getScriptData - . fromJust - . eitherToMaybe - . C.deserialiseFromCBOR C.AsHashableScriptData - . Base16.decodeBase16Lenient - . encodeUtf8 - let ~(Just (_, _, state)) = PlutusLedgerApi.V1.fromData @(CEMScriptDatum script) datumAsData - pure state - -hasAddr :: C.Address C.ShelleyAddr -> TxOutput -> Bool -hasAddr addr' output = - let addr = output ^. address - in fromOuraAddress addr == addr' - -fromOuraAddress :: Address -> C.Address C.ShelleyAddr -fromOuraAddress (MkAddressAsBase64 addr) = - addr - & fromJust - . eitherToMaybe - . SerialiseRaw.deserialiseFromRawBytes (C.AsAddress C.AsShelleyAddr) - . Base16.decodeBase16Lenient - . encodeUtf8 - data TxEvent = MkTxEvent { _parsed_tx :: Tx , _point :: String -- "Origin" @@ -488,93 +32,3 @@ mkTxEvent _parsed_tx = txToBS :: TxEvent -> BS.ByteString txToBS = LBS.toStrict . Aeson.encode - -encodePlutusData :: PlutusLedgerApi.V1.Data -> PlutusData -encodePlutusData = MkPlutusData . datumToJson - -datumToJson :: PlutusLedgerApi.V1.Data -> Aeson.Value -{-# NOINLINE datumToJson #-} -datumToJson = - \case - PlutusLedgerApi.V1.Constr n fields -> - Aeson.object - [ "constr" - .= Aeson.object - [ "tag" .= Aeson.Number (fromInteger n) - , "any_constructor" .= Aeson.Number 0 - , "fields" - .= Aeson.Array - (Vec.fromList $ datumToJson <$> fields) - ] - ] - PlutusLedgerApi.V1.Map kvs -> - Aeson.object - [ "map" - .= Aeson.object - [ "pairs" - .= Aeson.Array - ( Vec.fromList $ - kvs <&> \(k, v) -> - Aeson.object - [ "key" .= datumToJson k - , "value" .= datumToJson v - ] - ) - ] - ] - PlutusLedgerApi.V1.I n -> - Aeson.object - [ "big_int" - .= Aeson.object - [ "big_n_int" - .= Aeson.String - ( Base64.Types.extractBase64 $ - Base64.encodeBase64 $ - BS.pack $ - fromInteger - <$> digits @Integer @Double 16 n - ) - ] - ] - PlutusLedgerApi.V1.B bs -> - Aeson.object - [ "bounded_bytes" - .= Aeson.String - ( Base64.Types.extractBase64 $ - Base64.encodeBase64 bs - ) - ] - PlutusLedgerApi.V1.List xs -> - Aeson.object - [ "array" - .= Aeson.object - [ "items" .= Aeson.Array (datumToJson <$> Vec.fromList xs) - ] - ] - -serialisePubKeyHash :: PlutusLedgerApi.V1.PubKeyHash -> Hash28 -serialisePubKeyHash = MkBlake2b244Hex . serialiseAsHex . PlutusLedgerApi.V1.getPubKeyHash - -serialiseCurrencySymbol :: PlutusLedgerApi.V1.CurrencySymbol -> Hash28 -serialiseCurrencySymbol = MkBlake2b244Hex . serialiseAsHex . PlutusLedgerApi.V1.unCurrencySymbol - -serialiseScriptHash :: PlutusLedgerApi.V1.ScriptHash -> Hash28 -serialiseScriptHash = MkBlake2b244Hex . serialiseAsHex . PlutusLedgerApi.V1.getScriptHash - -serialiseTxHash :: PlutusLedgerApi.V1.TxId -> Hash32 -serialiseTxHash = MkBlake2b255Hex . serialiseAsHex . PlutusLedgerApi.V1.getTxId - -serialiseAsHex :: PlutusLedgerApi.V1.BuiltinByteString -> T.Text -serialiseAsHex = - Base16.Types.extractBase16 - . Base16.encodeBase16 - . PlutusLedgerApi.V1.fromBuiltin - -plutusAddressToOuraAddress :: (HasCallStack) => PlutusLedgerApi.V1.Address -> Address -plutusAddressToOuraAddress = - MkAddressAsBase64 - . Base64.extractBase64 - . Base64.encodeBase64 - . SerialiseRaw.serialiseToRawBytes - . either error id - . Address.plutusAddressToShelleyAddress Ledger.Mainnet diff --git a/test/OuraFilters.hs b/test/OuraFilters/Simple.hs similarity index 59% rename from test/OuraFilters.hs rename to test/OuraFilters/Simple.hs index fbf0fbb..7d510ed 100644 --- a/test/OuraFilters.hs +++ b/test/OuraFilters/Simple.hs @@ -2,9 +2,10 @@ {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} -module OuraFilters (ouraFiltersSpec) where +module OuraFilters.Simple (simpleSpec) where -import Cardano.CEM.Indexing qualified as Config +import Cardano.CEM.Indexing.Oura qualified as Config +import Cardano.CEM.Indexing.Tx qualified as Tx import Control.Lens (ix, (.~)) import Control.Monad ((>=>)) import Data.Aeson ((.:)) @@ -13,8 +14,8 @@ import Data.Aeson.Types qualified as Aeson import Data.ByteString qualified as BS import Data.Function ((&)) import Data.Text qualified as T -import Oura (Oura (receive, send, shutDown)) -import Oura qualified +import Oura.Communication (Oura (receive, send, shutDown)) +import Oura.Communication qualified as Oura import OuraFilters.Auction qualified import OuraFilters.Mock qualified as Mock import PlutusLedgerApi.V1 qualified as V1 @@ -25,9 +26,9 @@ import Prelude exampleMatchingTx :: Mock.TxEvent exampleMatchingTx = exampleTx - & Mock.parsed_tx . Mock.inputs . ix 0 . Mock.as_output . Mock.address .~ inputAddress + & Mock.parsed_tx . Tx.inputs . ix 0 . Tx.as_output . Tx.address .~ inputAddress where - inputAddress = Mock.MkAddressAsBase64 "AZSTMVzZLrXYxDBOZ7fhauNtYdNFAmlGV4EaLI4ze2LP/2QDoGo6y8NPjEYAPGn+eaNijO+pxHJR" + inputAddress = Tx.MkAddressAsBase64 "AZSTMVzZLrXYxDBOZ7fhauNtYdNFAmlGV4EaLI4ze2LP/2QDoGo6y8NPjEYAPGn+eaNijO+pxHJR" exampleFilter :: Config.Filter exampleFilter = Config.selectByAddress "addr1qx2fxv2umyhttkxyxp8x0dlpdt3k6cwng5pxj3jhsydzer3n0d3vllmyqwsx5wktcd8cc3sq835lu7drv2xwl2wywfgse35a3x" @@ -35,36 +36,36 @@ exampleFilter = Config.selectByAddress "addr1qx2fxv2umyhttkxyxp8x0dlpdt3k6cwng5p exampleTx :: Mock.TxEvent exampleTx = Mock.mkTxEvent $ - Mock.arbitraryTx - & Mock.inputs - .~ [ Mock.MkTxInput - { Mock._tx_hash = Mock.MkBlake2b255Hex "af6366838cfac9cc56856ffe1d595ad1dd32c9bafb1ca064a08b5c687293110f" - , Mock._output_index = 5 - , Mock._as_output = out - , Mock._redeemer = + Tx.arbitraryTx + & Tx.inputs + .~ [ Tx.MkTxInput + { Tx._tx_hash = Tx.MkBlake2b255Hex "af6366838cfac9cc56856ffe1d595ad1dd32c9bafb1ca064a08b5c687293110f" + , Tx._output_index = 5 + , Tx._as_output = out + , Tx._redeemer = Just $ - Mock.MkRedeemer - { _purpose = Mock.PURPOSE_UNSPECIFIED - , payload = Mock.encodePlutusData (V1.I 212) + Tx.MkRedeemer + { _purpose = Tx.PURPOSE_UNSPECIFIED + , payload = Tx.encodePlutusData (V1.I 212) } } ] - & Mock.outputs .~ [out] - & Mock.txCollateral . Mock.collateral_return . Mock.coin .~ 25464 - & Mock.txCollateral . Mock.total_collateral .~ 2555 - & Mock.fee .~ 967 - & Mock.validity .~ Mock.MkTxValidity {Mock._start = 324, Mock._ttl = 323} + & Tx.outputs .~ [out] + & Tx.txCollateral . Tx.collateral_return . Tx.coin .~ 25464 + & Tx.txCollateral . Tx.total_collateral .~ 2555 + & Tx.fee .~ 967 + & Tx.validity .~ Tx.MkTxValidity {Tx._start = 324, Tx._ttl = 323} where out = - Mock.MkTxOutput - { Mock._address = Mock.MkAddressAsBase64 "cM+tGRS1mdGL/9FNK71pYBnCiZy91qAzJc32gLw=" - , Mock._coin = 254564 - , Mock._assets = [] - , Mock._datum = + Tx.MkTxOutput + { Tx._address = Tx.MkAddressAsBase64 "cM+tGRS1mdGL/9FNK71pYBnCiZy91qAzJc32gLw=" + , Tx._coin = 254564 + , Tx._assets = [] + , Tx._datum = Just $ - Mock.MkDatum - { Mock._payload = - Mock.encodePlutusData $ + Tx.MkDatum + { Tx._payload = + Tx.encodePlutusData $ V1.List [ V1.Map [ (V1.I 2, V1.I 33) @@ -73,14 +74,14 @@ exampleTx = , V1.I 34 , V1.B "aboba" ] - , Mock.hash = Mock.MkBlake2b255Hex "af6366838cfac9cc56856ffe1d595ad1dd32c9bafb1ca064a08b5c687293110f" - , Mock._original_cbor = "" + , Tx.hash = Tx.MkBlake2b255Hex "af6366838cfac9cc56856ffe1d595ad1dd32c9bafb1ca064a08b5c687293110f" + , Tx._original_cbor = "" } - , Mock._script = Nothing + , Tx._script = Nothing } -ouraFiltersSpec :: Spec -ouraFiltersSpec = Utils.killProcessesOnError do +simpleSpec :: Spec +simpleSpec = Utils.killProcessesOnError do focus $ it "Oura filters match tx it have to match, and don't match other" \spotGarbage -> let tx = Mock.txToBS exampleTx diff --git a/test/Utils.hs b/test/Utils.hs index 9138d94..7457007 100644 --- a/test/Utils.hs +++ b/test/Utils.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BlockArguments #-} module Utils where @@ -69,19 +68,6 @@ resultToEither :: Aeson.Result a -> Either String a resultToEither (Aeson.Success a) = Right a resultToEither (Aeson.Error err) = Left err -totalDigits :: forall n m. (Integral n, RealFrac m, Floating m) => n -> n -> n -totalDigits base = round @m . logBase (fromIntegral base) . fromIntegral - -digits :: forall n m. (Integral n, RealFrac m, Floating m) => n -> n -> [n] -digits base n = - fst <$> case reverse [0 .. totalDigits @n @m base n - 1] of - (i : is) -> - scanl - (\(_, remainder) digit -> remainder `divMod` (base ^ digit)) - (n `divMod` (base ^ i)) - is - [] -> [] - execClb :: ClbRunner a -> IO a execClb = execOnIsolatedClb $ lovelaceToValue 300_000_000