diff --git a/cabal.project b/cabal.project index 0fff610..8c20c37 100644 --- a/cabal.project +++ b/cabal.project @@ -22,7 +22,7 @@ source-repository-package tag: d5b0e7ce07258482d53704ce19383013b1fa6610 --sha256: 6+Os/mQDzBOU+TkTD+n/T1MFcI+Mn0/tcBMJhLRfqyA= --- FIXME: Cannot use new commit, because it requires `plutus-ledger-api==1.29` +-- Cannot use new commit, because it requires `plutus-ledger-api==1.29` source-repository-package type: git location: https://github.com/Plutonomicon/plutarch-plutus diff --git a/cem-script.cabal b/cem-script.cabal index f6009f4..5c4896b 100644 --- a/cem-script.cabal +++ b/cem-script.cabal @@ -4,7 +4,7 @@ version: 0.1.0 synopsis: CEM Script - a Cardano dApp SDK homepage: https://github.com/mlabs-haskell/cem-script author: MLabs -maintainer: gregory@mlabs.city +maintainer: ilia@mlabs.city data-files: README.md tested-with: GHC ==9.6.3 @@ -15,9 +15,11 @@ flag dev default: True manual: False -common common-lang - -- Options from MLabs styleguide +flag force-recomp + description: Compile with -fforce-recomp and -Wunused-packages + default: False +common common-lang ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints @@ -26,8 +28,15 @@ common common-lang if !flag(dev) ghc-options: -Werror + if flag(dev) + default-extensions: PartialTypeSignatures + + if flag(force-recomp) + ghc-options: -fforce-recomp -Wunused-packages + build-depends: , base + , extra , mtl , transformers @@ -52,9 +61,6 @@ common common-lang UndecidableInstances ViewPatterns - if flag(dev) - default-extensions: PartialTypeSignatures - default-language: GHC2021 common common-onchain @@ -144,10 +150,11 @@ 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 Cardano.CEM.OffChain Cardano.CEM.OnChain Cardano.CEM.Testing.StateMachine @@ -155,15 +162,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: @@ -205,12 +217,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-lib/cardano-extras/Cardano/Extras.hs b/src-lib/cardano-extras/Cardano/Extras.hs index 3186fc5..1826335 100644 --- a/src-lib/cardano-extras/Cardano/Extras.hs +++ b/src-lib/cardano-extras/Cardano/Extras.hs @@ -275,7 +275,6 @@ mintedTokens :: [(AssetName, Quantity)] -> Cardano.TxMintValue BuildTx Era mintedTokens script redeemer assets = - -- FIXME: is hardcoding era correct? TxMintValue Cardano.MaryEraOnwardsBabbage mintedTokens' mintedWitnesses' where mintedTokens' = valueFromList (fmap (first (AssetId policyId)) assets) diff --git a/src-lib/data-spine/Data/Spine.hs b/src-lib/data-spine/Data/Spine.hs index 82ebcfa..ff8d68b 100644 --- a/src-lib/data-spine/Data/Spine.hs +++ b/src-lib/data-spine/Data/Spine.hs @@ -12,9 +12,9 @@ import Language.Haskell.TH.Syntax -- | Definitions -{- | Spine is datatype, which tags constructors of ADT. -| TH deriving utility generates Spines, which are Enums, -| but one could introduce more complex Spine datatypes manually. +{- | Spine is datatype, which tags only constructors of ADT skipping their content. + TH deriving utility generates Spines which are Enums but one could introduce + more complex Spine datatypes manually. -} class ( Ord (Spine sop) @@ -88,8 +88,6 @@ deriveSpine name = do suffix = "Spine" spineName = addSuffix name suffix spineDec <- deriveTags name suffix [''Eq, ''Ord, ''Enum, ''Show] - -- TODO: derive Sing - -- TODO: derive HasField (OfSpine ...) decls <- [d| diff --git a/src/Cardano/CEM.hs b/src/Cardano/CEM.hs index 71f0c2e..69ec9a8 100644 --- a/src/Cardano/CEM.hs +++ b/src/Cardano/CEM.hs @@ -111,7 +111,7 @@ class type EqShow datatype = ( Prelude.Eq datatype , Prelude.Show datatype - -- TODO: add IsData here? (now it breaks Plutus compilation) + -- Shoul we add IsData here? (now it breaks Plutus compilation) ) {- | All associated types for 'CEMScript' class defined separately to simplify @@ -223,7 +223,7 @@ data TxFanKind -- | Constraint on a single tx fan data TxFanFilter script = MkTxFanFilter { address :: AddressSpec - , rest :: FilterDatum script -- TODO: not ideal naming + , datumFilter :: FilterDatum script } deriving stock (Show, Prelude.Eq) @@ -252,8 +252,8 @@ bySameCEM = UnsafeBySameCEM . toBuiltinData -- | How many tx fans should satify a 'TxFansConstraint' data Quantifier - = ExactlyNFans Integer -- TODO: use natural numbers - | FansWithTotalValueOfAtLeast Value -- TODO: use natural numbers + = ExactlyNFans Integer -- Here we'd better use natural numbers + | FansWithTotalValueOfAtLeast Value deriving stock (Show) -- | A constraint on Tx inputs or Outputs. diff --git a/src/Cardano/CEM/Address.hs b/src/Cardano/CEM/Address.hs index be8c6b5..a78810d 100644 --- a/src/Cardano/CEM/Address.hs +++ b/src/Cardano/CEM/Address.hs @@ -1,6 +1,7 @@ module Cardano.CEM.Address ( - cardanoAddressBech32, + scriptCredential, scriptCardanoAddress, + cardanoAddressBech32, plutusAddressToShelleyAddress, AddressBech32 (MkAddressBech32, unAddressBech32), ) where @@ -14,7 +15,7 @@ import Cardano.Ledger.BaseTypes qualified as Ledger import Cardano.Ledger.Credential qualified as Cred import Cardano.Ledger.Hashes qualified import Cardano.Ledger.Keys qualified as Ledger.Keys -import Data.Data (Proxy (Proxy)) +import Data.Proxy (Proxy) import Data.String (IsString) import Data.Text qualified as T import Plutus.Extras qualified @@ -33,13 +34,22 @@ scriptCardanoAddress :: Proxy script -> Cardano.Api.Ledger.Network -> Either String (Cardano.Api.Address Cardano.Api.ShelleyAddr) -scriptCardanoAddress _ network = +scriptCardanoAddress p network = plutusAddressToShelleyAddress network . flip PlutusLedgerApi.V1.Address Nothing - . PlutusLedgerApi.V1.ScriptCredential + . scriptCredential + $ p + +scriptCredential :: + forall script. + (Compiled.CEMScriptCompiled script) => + Proxy script -> + PlutusLedgerApi.V1.Credential +scriptCredential p = + PlutusLedgerApi.V1.ScriptCredential . Plutus.Extras.scriptValidatorHash . Compiled.cemScriptCompiled - $ Proxy @script + $ p plutusAddressToShelleyAddress :: Cardano.Api.Ledger.Network -> 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/Examples/Auction.hs b/src/Cardano/CEM/Examples/Auction.hs index f663141..5af99e2 100644 --- a/src/Cardano/CEM/Examples/Auction.hs +++ b/src/Cardano/CEM/Examples/Auction.hs @@ -1,5 +1,7 @@ {-# LANGUAGE NoPolyKinds #-} +-- {-# OPTIONS_GHC -Wno-unrecognised-pragmas -ddump-splices #-} + module Cardano.CEM.Examples.Auction where import PlutusTx.Prelude diff --git a/src/Cardano/CEM/Indexing/Event.hs b/src/Cardano/CEM/Indexing/Event.hs new file mode 100644 index 0000000..8199c23 --- /dev/null +++ b/src/Cardano/CEM/Indexing/Event.hs @@ -0,0 +1,146 @@ +{-# 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/src/Cardano/CEM/Monads.hs b/src/Cardano/CEM/Monads.hs index 301da94..713ba94 100644 --- a/src/Cardano/CEM/Monads.hs +++ b/src/Cardano/CEM/Monads.hs @@ -29,7 +29,6 @@ data CEMAction script deriving stock instance (CEMScript script) => Show (CEMAction script) --- FIXME: use generic Some data SomeCEMAction where MkSomeCEMAction :: forall script. @@ -38,7 +37,6 @@ data SomeCEMAction where SomeCEMAction instance Show SomeCEMAction where - -- FIXME: show script name show :: SomeCEMAction -> String show (MkSomeCEMAction action) = show action @@ -54,8 +52,7 @@ data TxSpec = MkTxSpec data BlockchainParams = MkBlockchainParams { protocolParameters :: PParams LedgerEra , systemStart :: SystemStart - , -- FIXME: rename - eraHistory :: LedgerEpochInfo + , ledgerEpochInfo :: LedgerEpochInfo , stakePools :: Set PoolId } deriving stock (Show) @@ -109,8 +106,7 @@ data ResolvedTx = MkResolvedTx , toMint :: TxMintValue BuildTx Era , interval :: Interval POSIXTime , additionalSigners :: [PubKeyHash] - , -- FIXME - signer :: ~(SigningKey PaymentKey) + , signer :: ~(SigningKey PaymentKey) } deriving stock (Show, Eq) @@ -141,6 +137,9 @@ data TxResolutionError -- | Ability to send transaction to chain class (MonadQueryUtxo m) => MonadSubmitTx m where submitResolvedTx :: ResolvedTx -> m (Either TxSubmittingError TxId) + submitResolvedTxRet :: + ResolvedTx -> + m (Either TxSubmittingError (TxBodyContent BuildTx Era, TxBody Era, TxInMode, UTxO Era)) -- | Stuff needed to use monad for local testing class (MonadSubmitTx m) => MonadTest m where diff --git a/src/Cardano/CEM/Monads/CLB.hs b/src/Cardano/CEM/Monads/CLB.hs index 0a887ba..5c73f28 100644 --- a/src/Cardano/CEM/Monads/CLB.hs +++ b/src/Cardano/CEM/Monads/CLB.hs @@ -37,6 +37,9 @@ import Cardano.CEM.Monads.L1Commons import Cardano.CEM.OffChain (fromPlutusAddressInMonad) import Control.Monad.Reader (MonadReader (..), ReaderT (..)) +import Cardano.Extras (Era) +import Data.Either.Extra (mapRight) + instance (MonadReader r m) => MonadReader r (ClbT m) where ask = lift ask local f action = ClbT $ local f $ unwrapClbT action @@ -57,14 +60,14 @@ instance queryBlockchainParams = do protocolParameters <- gets (mockConfigProtocol . mockConfig) slotConfig <- gets (mockConfigSlotConfig . mockConfig) - eraHistory <- LedgerEpochInfo <$> getEpochInfo + ledgerEpochInfo <- LedgerEpochInfo <$> getEpochInfo let systemStart = SystemStart $ posixTimeToUTCTime $ scSlotZeroTime slotConfig return $ MkBlockchainParams { protocolParameters , systemStart - , eraHistory + , ledgerEpochInfo , -- Staking is not supported stakePools = Set.empty } @@ -88,18 +91,23 @@ instance (Monad m, MonadBlockchainParams (ClbT m)) => MonadQueryUtxo (ClbT m) wh ByTxIns txIns -> return $ \txIn _ -> txIn `elem` txIns instance (Monad m, MonadBlockchainParams (ClbT m)) => MonadSubmitTx (ClbT m) where - submitResolvedTx :: ResolvedTx -> ClbT m (Either TxSubmittingError TxId) - submitResolvedTx tx = do + submitResolvedTxRet :: + ResolvedTx -> + ClbT m (Either TxSubmittingError (TxBodyContent BuildTx Era, TxBody Era, TxInMode, UTxO Era)) + submitResolvedTxRet tx = do cardanoTxBodyFromResolvedTx tx >>= \case - Right (body, TxInMode ShelleyBasedEraBabbage tx') -> do + Right (preBody, body, txInMode@(TxInMode ShelleyBasedEraBabbage tx'), utxo) -> do result <- sendTx tx' case result of - Success _ _ -> return $ Right $ getTxId body + Success _ _ -> return $ Right (preBody, body, txInMode, utxo) Fail _ validationError -> return $ Left $ UnhandledNodeSubmissionError validationError - Right (_, _) -> fail "Unsupported tx format" + Right _ -> fail "Unsupported tx format" Left e -> return $ Left $ UnhandledAutobalanceError e + submitResolvedTx :: ResolvedTx -> ClbT m (Either TxSubmittingError TxId) + submitResolvedTx tx = mapRight (getTxId . (\(_, a, _, _) -> a)) <$> submitResolvedTxRet tx + instance (Monad m, MonadBlockchainParams (ClbT m)) => MonadTest (ClbT m) where getTestWalletSks = return $ map intToCardanoSk [1 .. 10] diff --git a/src/Cardano/CEM/Monads/L1.hs b/src/Cardano/CEM/Monads/L1.hs deleted file mode 100644 index 998e2d6..0000000 --- a/src/Cardano/CEM/Monads/L1.hs +++ /dev/null @@ -1,151 +0,0 @@ -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - -module Cardano.CEM.Monads.L1 where - -import Prelude - -import Control.Monad.Reader (MonadReader (..), ReaderT (..)) -import Data.ByteString qualified as BS -import Data.Set qualified as Set - --- Cardano imports -import Cardano.Api hiding (queryUtxo) -import Cardano.Api.InMode (TxValidationError (..)) -import Ouroboros.Network.Protocol.LocalStateQuery.Type (Target (..)) - --- Project imports - -import Cardano.CEM.Monads ( - BlockchainParams (MkBlockchainParams), - MonadBlockchainParams (..), - MonadQueryUtxo (..), - MonadSubmitTx (..), - MonadTest (..), - ResolvedTx, - TxSubmittingError (..), - UtxoQuery (..), - ) -import Cardano.CEM.Monads.L1Commons (cardanoTxBodyFromResolvedTx) -import Cardano.CEM.OffChain (fromPlutusAddressInMonad) -import Cardano.Extras (Era, addressInEraToAny, cardanoModeParams, parseSigningKeyTE) - -newtype ExecutionContext = MkExecutionContext - { localNode :: LocalNodeConnectInfo - } - -newtype L1Runner a = MkL1Runner - { unL1Runner :: ReaderT ExecutionContext IO a - } - deriving newtype - ( Functor - , Applicative - , Monad - , MonadIO - , MonadFail - , MonadReader ExecutionContext - ) - --- Monad implementations - -instance MonadBlockchainParams L1Runner where - askNetworkId = localNodeNetworkId . localNode <$> ask - queryCurrentSlot = do - node <- localNode <$> ask - tip <- liftIO $ getLocalChainTip node - case tip of - ChainTipAtGenesis -> pure 0 - ChainTip slotNo _ _ -> pure slotNo - - queryBlockchainParams = do - MkBlockchainParams - <$> queryCardanoNodeWrapping QueryProtocolParameters - <*> queryCardanoNode QuerySystemStart - <*> (toLedgerEpochInfo <$> queryCardanoNode QueryEraHistory) - <*> queryCardanoNodeWrapping QueryStakePools - - -- FIXME - logEvent _ = return () - eventList = return [] - -queryCardanoNodeWrapping :: QueryInShelleyBasedEra Era b -> L1Runner b -queryCardanoNodeWrapping query = - handleEitherEra =<< queryCardanoNode wrapped - where - handleEitherEra (Right x) = return x - handleEitherEra (Left _) = fail "Unexpected era mismatch" - wrapped = QueryInEra (QueryInShelleyBasedEra shelleyBasedEra query) - --- Design inspired by `Hydra.Chain.CardanoClient` helpers -queryCardanoNode :: - QueryInMode b -> L1Runner b -queryCardanoNode query = do - node <- localNode <$> ask - result <- liftIO $ queryNodeLocalState node VolatileTip query - case result of - -- FIXME: better handling of wrong-era exceptions - Right x -> return x - _ -> fail "Unhandled Cardano API error" - -instance MonadQueryUtxo L1Runner where - queryUtxo query = do - utxoQuery <- case query of - ByTxIns txIns -> - return $ QueryUTxOByTxIn (Set.fromList txIns) - ByAddresses addresses -> do - cardanoAddresses <- - map addressInEraToAny <$> mapM fromPlutusAddressInMonad addresses - return $ QueryUTxOByAddress (Set.fromList cardanoAddresses) - queryCardanoNodeWrapping $ QueryUTxO utxoQuery - -instance MonadSubmitTx L1Runner where - -- FIXME: code duplication, probably refactor out - submitResolvedTx :: ResolvedTx -> L1Runner (Either TxSubmittingError TxId) - submitResolvedTx tx = do - ci <- localNode <$> ask - cardanoTxBodyFromResolvedTx tx >>= \case - Right (body, txInMode) -> - liftIO $ - submitTxToNodeLocal ci txInMode >>= \case - SubmitSuccess -> - return $ Right $ getTxId body - -- FIXME: check other eras support - SubmitFail (TxValidationErrorInCardanoMode (ShelleyTxValidationError ShelleyBasedEraBabbage e)) -> - return $ Left $ UnhandledNodeSubmissionError e - SubmitFail (TxValidationErrorInCardanoMode _) -> - error "Era mismatch error" - SubmitFail (TxValidationEraMismatch _) -> - error "Era mismatch error" - Left e -> return $ Left $ UnhandledAutobalanceError e - -instance MonadTest L1Runner where - -- FIXME: cache keys and better error handling - getTestWalletSks = do - mapM keyN [0 .. 2] - where - keyN n = do - keyBytes <- liftIO $ BS.readFile $ keysPaths !! fromInteger n - case parseSigningKeyTE keyBytes of - Just key -> return key - Nothing -> fail "Could not read key" - keysPaths = - [ "./devnet/credentials/faucet.sk" - , "./devnet/credentials/bob.sk" - , "./devnet/credentials/carol.sk" - ] - --- | Starting local devnet -localDevnetNetworkId :: NetworkId -localDevnetNetworkId = Testnet $ NetworkMagic 42 - -execOnLocalDevnet :: L1Runner a -> IO a -execOnLocalDevnet action = - runReaderT (unL1Runner action) localNodeContext - where - localNodeContext = - MkExecutionContext - { localNode = - LocalNodeConnectInfo - cardanoModeParams - localDevnetNetworkId - "./devnet/node.socket" - } diff --git a/src/Cardano/CEM/Monads/L1Commons.hs b/src/Cardano/CEM/Monads/L1Commons.hs index ff86e98..16aa9db 100644 --- a/src/Cardano/CEM/Monads/L1Commons.hs +++ b/src/Cardano/CEM/Monads/L1Commons.hs @@ -3,31 +3,22 @@ -- | Code common for resolving Tx of backends which use `cardano-api` module Cardano.CEM.Monads.L1Commons where -import Prelude - -import Data.List (nub) -import Data.Map qualified as Map - --- Cardano imports import Cardano.Api hiding (queryUtxo) import Cardano.Api.Shelley (LedgerProtocolParameters (..)) - --- Project imports import Cardano.CEM.Monads import Cardano.CEM.OffChain import Cardano.Extras +import Data.List (nub) +import Data.Map qualified as Map import Data.Maybe (mapMaybe) +import Prelude --- Main function - +-- | Main function cardanoTxBodyFromResolvedTx :: (MonadQueryUtxo m, MonadBlockchainParams m) => ResolvedTx -> - m (Either (TxBodyErrorAutoBalance Era) (TxBody Era, TxInMode)) + m (Either (TxBodyErrorAutoBalance Era) (TxBodyContent BuildTx Era, TxBody Era, TxInMode, UTxO Era)) cardanoTxBodyFromResolvedTx (MkResolvedTx {..}) = do - -- (lowerBound, upperBound) <- convertValidityBound validityBound - - -- FIXME: proper fee coverage selection utxo <- queryUtxo $ ByAddresses [signingKeyToAddress signer] let feeTxIns = Map.keys $ unUTxO utxo @@ -41,8 +32,7 @@ cardanoTxBodyFromResolvedTx (MkResolvedTx {..}) = do let preBody = TxBodyContent - { -- FIXME: duplicate TxIn for coin-selection redeemer bug - txIns = nub allTxIns + { txIns = nub allTxIns -- duplicate TxIn for coin-selection redeemer bug , txInsCollateral = TxInsCollateral AlonzoEraOnwardsBabbage feeTxIns , txInsReference = @@ -93,19 +83,19 @@ cardanoTxBodyFromResolvedTx (MkResolvedTx {..}) = do lift $ recordFee txInsUtxo body - return (body, txInMode) + return (preBody, body, txInMode, txInsUtxo) where recordFee txInsUtxo body@(TxBody content) = do case txFee content of TxFeeExplicit era coin -> do - MkBlockchainParams {protocolParameters, systemStart, eraHistory} <- + MkBlockchainParams {protocolParameters, systemStart, ledgerEpochInfo} <- queryBlockchainParams Right report <- return $ evaluateTransactionExecutionUnits (shelleyBasedToCardanoEra era) systemStart - eraHistory + ledgerEpochInfo (LedgerProtocolParameters protocolParameters) txInsUtxo body @@ -150,13 +140,13 @@ callBodyAutoBalance preBody utxo changeAddress = do - MkBlockchainParams {protocolParameters, systemStart, eraHistory, stakePools} <- + MkBlockchainParams {protocolParameters, systemStart, ledgerEpochInfo, stakePools} <- queryBlockchainParams let result = makeTransactionBodyAutoBalance @Era shelleyBasedEra systemStart - eraHistory + ledgerEpochInfo (LedgerProtocolParameters protocolParameters) stakePools Map.empty -- Stake credentials diff --git a/src/Cardano/CEM/OffChain.hs b/src/Cardano/CEM/OffChain.hs index d96a64a..dbb1d62 100644 --- a/src/Cardano/CEM/OffChain.hs +++ b/src/Cardano/CEM/OffChain.hs @@ -33,6 +33,7 @@ import Cardano.CEM import Cardano.CEM.Monads import Cardano.CEM.OnChain (CEMScriptCompiled (..), cemScriptAddress) import Cardano.Extras +import Data.Either.Extra (mapRight) import Data.Spine (HasSpine (getSpine)) fromPlutusAddressInMonad :: @@ -65,8 +66,7 @@ failLeft (Right value) = return value -- TODO: use regular CEMScript cemTxOutDatum :: (CEMScriptCompiled script) => TxOut ctx Era -> Maybe (CEMScriptDatum script) -cemTxOutDatum txOut = - fromData =<< toPlutusData <$> getScriptData <$> mTxOutDatum txOut +cemTxOutDatum txOut = fromData . (toPlutusData <$> getScriptData) =<< mTxOutDatum txOut cemTxOutState :: (CEMScriptCompiled script) => TxOut ctx Era -> Maybe (State script) cemTxOutState txOut = @@ -124,7 +124,7 @@ resolveAction mScriptTxIn = case transitionStage (Proxy :: Proxy script) Map.! getSpine transition of (_, Nothing, _) -> Nothing _ -> mScriptTxIn' - mState = cemTxOutState =<< snd <$> mScriptTxIn + mState = cemTxOutState . snd =<< mScriptTxIn witnesedScriptTxIns = case mScriptTxIn of Just (txIn, _) -> @@ -168,7 +168,7 @@ resolveAction scriptAddress = cemScriptAddress (Proxy :: Proxy script) resolveTxIn (MkTxFansC _ (MkTxFanFilter addressSpec _) _) = do utxo <- lift $ queryUtxo $ ByAddresses [address] - return $ map (\(x, y) -> (withKeyWitness x, y)) $ Map.toList $ unUTxO utxo + return $ map (first withKeyWitness) $ Map.toList $ unUTxO utxo where address = addressSpecToAddress scriptAddress addressSpec compileTxConstraint @@ -178,12 +178,13 @@ resolveAction TxOut address' value datum ReferenceScriptNone return $ case quantor of ExactlyNFans n -> replicate (fromInteger n) $ compiledTxOut minUtxoValue - FansWithTotalValueOfAtLeast value -> [compiledTxOut $ (convertTxOut $ fromPlutusValue value) <> minUtxoValue] + FansWithTotalValueOfAtLeast value -> + [compiledTxOut $ convertTxOut (fromPlutusValue value) <> minUtxoValue] where datum = case filterSpec of AnyDatum -> TxOutDatumNone ByDatum datum' -> mkInlineDatum datum' - -- FIXME: Can be optimized via Plutarch + -- This case probably can be optimized via Plutarch UnsafeBySameCEM newState -> let cemDatum :: CEMScriptDatum script @@ -195,10 +196,8 @@ resolveAction in mkInlineDatum cemDatum address = addressSpecToAddress scriptAddress addressSpec - -- TODO: protocol params - -- calculateMinimumUTxO era txout bpp + -- TODO: protocol params calculateMinimumUTxO era txout bpp minUtxoValue = convertTxOut $ lovelaceToValue 3_000_000 - -- TODO convertTxOut x = TxOutValueShelleyBased shelleyBasedEra $ toMaryValue x @@ -215,6 +214,10 @@ resolveTx spec = runExceptT $ do mergedSpec' = head actionsSpecs mergedSpec = (mergedSpec' :: ResolvedTx) {signer = specSigner spec} + -- liftIO $ do + -- putStr "Resolved spec: " + -- print mergedSpec + return mergedSpec resolveTxAndSubmit :: @@ -228,3 +231,15 @@ resolveTxAndSubmit spec = do ExceptT $ first UnhandledSubmittingError <$> result logEvent $ SubmittedTxSpec spec result return result + +resolveTxAndSubmitRet :: + (MonadQueryUtxo m, MonadSubmitTx m, MonadIO m) => + TxSpec -> + m (Either TxResolutionError (TxBodyContent BuildTx Era, TxBody Era, TxInMode, UTxO Era)) +resolveTxAndSubmitRet spec = do + result <- runExceptT $ do + resolved <- ExceptT $ resolveTx spec + let result = submitResolvedTxRet resolved + ExceptT $ first UnhandledSubmittingError <$> result + logEvent $ SubmittedTxSpec spec (mapRight (getTxId . (\(_, a, _, _) -> a)) result) + return result diff --git a/src/Cardano/CEM/OnChain.hs b/src/Cardano/CEM/OnChain.hs index 01a3374..fdfb0e2 100644 --- a/src/Cardano/CEM/OnChain.hs +++ b/src/Cardano/CEM/OnChain.hs @@ -7,6 +7,7 @@ module Cardano.CEM.OnChain ( CEMScriptCompiled (..), + CEMScriptIsData, cemScriptAddress, genericCEMScript, ) where diff --git a/src/Cardano/CEM/Testing/StateMachine.hs b/src/Cardano/CEM/Testing/StateMachine.hs index caeec10..7778c96 100644 --- a/src/Cardano/CEM/Testing/StateMachine.hs +++ b/src/Cardano/CEM/Testing/StateMachine.hs @@ -1,27 +1,30 @@ {-# OPTIONS_GHC -Wno-orphans #-} -{- | Generic utils for using `quickcheck-dynamic` -FIXME: refactor and add documentation --} +-- | Generic utils for using `quickcheck-dynamic` module Cardano.CEM.Testing.StateMachine where import Prelude +import Cardano.Api (PaymentKey, SigningKey, Value) +import Cardano.CEM (CEMParams (..)) +import Cardano.CEM hiding (scriptParams) +import Cardano.CEM.Monads (CEMAction (..), MonadSubmitTx (..), ResolvedTx (..), SomeCEMAction (..), TxSpec (..)) +import Cardano.CEM.Monads.CLB (ClbRunner, execOnIsolatedClb) +import Cardano.CEM.OffChain +import Cardano.CEM.OnChain (CEMScriptCompiled) +import Cardano.Extras (signingKeyToPKH) +import Clb (ClbT) import Control.Monad (void) import Control.Monad.Except (ExceptT (..), runExceptT) import Control.Monad.Trans (MonadIO (..)) import Data.Bifunctor (Bifunctor (..)) import Data.Data (Typeable) import Data.List (permutations) -import Data.Maybe (mapMaybe) +import Data.Maybe (isJust, mapMaybe) import Data.Set qualified as Set - +import Data.Spine (HasSpine (..), deriveSpine) import PlutusLedgerApi.V1 (PubKeyHash) import PlutusTx.IsData (FromData (..)) - -import Cardano.Api (PaymentKey, SigningKey, Value) - -import Clb (ClbT) import Test.QuickCheck import Test.QuickCheck.DynamicLogic (DynLogicModel) import Test.QuickCheck.Gen qualified as Gen @@ -38,16 +41,6 @@ import Test.QuickCheck.StateModel ( ) import Text.Show.Pretty (ppShow) -import Cardano.CEM (CEMParams (..)) -import Cardano.CEM hiding (scriptParams) -import Cardano.CEM.Monads (CEMAction (..), MonadSubmitTx (..), ResolvedTx (..), SomeCEMAction (..), TxSpec (..)) -import Cardano.CEM.Monads.CLB (ClbRunner, execOnIsolatedClb) -import Cardano.CEM.OffChain -import Cardano.CEM.OnChain (CEMScriptCompiled) -import Cardano.Extras (signingKeyToPKH) -import Data.Spine (HasSpine (..), deriveSpine) - --- FIXME: add more mutations and documentation data TxMutation = RemoveTxFan TxFanKind | ShuffleTxFan TxFanKind Int deriving stock (Eq, Show) @@ -180,10 +173,9 @@ instance (CEMScriptArbitrary script) => StateModel (ScriptState script) where -- Unreachable precondition _ _ = False - -- XXX: Check on ScriptState and it fields is required for shrinking - -- FIXME: docs on QD generation hacks + -- Check on ScriptState and it fields is required for shrinking validFailingAction (ScriptState {finished, state}) (ScriptTransition _ mutation) = - isNegativeMutation mutation && state /= Nothing && not finished + isNegativeMutation mutation && isJust state && not finished validFailingAction _ _ = False nextState Void (SetupConfig config) _var = ConfigSet config @@ -216,7 +208,7 @@ instance (CEMScriptArbitrary script) => StateModel (ScriptState script) where error "This StateModel instance support only with single-output scripts" outStates spec = mapMaybe decodeOutState $ constraints spec - decodeOutState c = case rest (txFansCFilter c) of + decodeOutState c = case datumFilter (txFansCFilter c) of UnsafeBySameCEM stateBS -> fromBuiltinData @(State script) stateBS _ -> Nothing @@ -336,7 +328,7 @@ runActionsInClb :: runActionsInClb genesisValue actions = monadic (ioProperty . execOnIsolatedClb genesisValue) $ void $ - runActions @(ScriptState state) @(ClbRunner) actions + runActions @(ScriptState state) @ClbRunner actions -- Orphans diff --git a/test/Auction.hs b/test/Auction.hs index 194bf2c..d10ae61 100644 --- a/test/Auction.hs +++ b/test/Auction.hs @@ -1,21 +1,23 @@ +{-# OPTIONS_GHC -Wno-name-shadowing #-} + module Auction where import Prelude -import Control.Monad.Trans (MonadIO (..)) -import PlutusLedgerApi.V1.Value (assetClassValue) - +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 PlutusLedgerApi.V1.Value (assetClassValue) import Test.Hspec (describe, it, shouldBe) - import TestNFT (testNftAssetClass) -import Utils (execClb, mintTestTokens, submitAndCheck) +import Utils (execClb, mintTestTokens, submitAndCheck, submitCheckReturn) auctionSpec = describe "Auction" $ do it "Wrong transition resolution error" $ execClb $ do @@ -61,7 +63,7 @@ auctionSpec = describe "Auction" $ do ] , specSigner = bidder1 } - ~( Left + ( Left ( MkTransitionError _ (StateMachineError "\"Incorrect state for transition\"") @@ -123,17 +125,12 @@ auctionSpec = describe "Auction" $ do ] , specSigner = bidder1 } - ~( Left - ( MkTransitionError - _ - (StateMachineError "\"Incorrect state for transition\"") - ) - ) <- - return result + (Left _) <- return result return () it "Successful transition flow" $ execClb $ do + network <- toShelleyNetwork <$> askNetworkId seller <- (!! 0) <$> getTestWalletSks bidder1 <- (!! 1) <$> getTestWalletSks @@ -155,16 +152,20 @@ auctionSpec = describe "Auction" $ do Nothing <- queryScriptState auctionParams - submitAndCheck $ - MkTxSpec - { actions = - [ MkSomeCEMAction $ MkCEMAction auctionParams Create - ] - , specSigner = seller - } + (preBody, utxo) <- + submitCheckReturn $ + MkTxSpec + { actions = + [ MkSomeCEMAction $ MkCEMAction auctionParams Create + ] + , specSigner = seller + } Just NotStarted <- queryScriptState auctionParams + mEvent <- liftIO $ extractEvent @SimpleAuction network $ resolvedTxToOura preBody utxo + liftIO $ mEvent `shouldBe` Just (Initial CreateSpine) + let initBid = MkBet @@ -176,57 +177,85 @@ auctionSpec = describe "Auction" $ do { better = signingKeyToPKH bidder1 , betAmount = 3_000_000 } + bid2 = + MkBet + { better = signingKeyToPKH bidder1 + , betAmount = 4_000_000 + } - submitAndCheck $ - MkTxSpec - { actions = - [ MkSomeCEMAction $ - MkCEMAction auctionParams Start - ] - , specSigner = seller - } + (preBody, utxo) <- + submitCheckReturn $ + MkTxSpec + { actions = + [ MkSomeCEMAction $ + MkCEMAction auctionParams Start + ] + , specSigner = seller + } Just (CurrentBid currentBid') <- queryScriptState auctionParams liftIO $ currentBid' `shouldBe` initBid - submitAndCheck $ - MkTxSpec - { actions = - [ MkSomeCEMAction $ - MkCEMAction auctionParams (MakeBid bid1) - ] - , specSigner = bidder1 - } + mEvent <- liftIO $ extractEvent @SimpleAuction network $ resolvedTxToOura preBody utxo + liftIO $ mEvent `shouldBe` Just (Following StartSpine) + + (preBody, utxo) <- + submitCheckReturn $ + MkTxSpec + { actions = + [ MkSomeCEMAction $ + MkCEMAction auctionParams (MakeBid bid1) + ] + , specSigner = bidder1 + } Just (CurrentBid currentBid) <- queryScriptState auctionParams liftIO $ currentBid `shouldBe` bid1 - submitAndCheck $ - MkTxSpec - { actions = - [ MkSomeCEMAction $ - MkCEMAction - auctionParams - ( MakeBid $ MkBet (signingKeyToPKH bidder1) 4_000_000 - ) - ] - , specSigner = bidder1 - } + mEvent <- liftIO $ extractEvent @SimpleAuction network $ resolvedTxToOura preBody utxo + liftIO $ mEvent `shouldBe` Just (Following MakeBidSpine) - submitAndCheck $ - MkTxSpec - { actions = - [ MkSomeCEMAction $ - MkCEMAction auctionParams Close - ] - , specSigner = seller - } + (preBody, utxo) <- + submitCheckReturn $ + MkTxSpec + { actions = + [ MkSomeCEMAction $ + MkCEMAction + auctionParams + ( MakeBid $ MkBet (signingKeyToPKH bidder1) 4_000_000 + ) + ] + , specSigner = bidder1 + } - submitAndCheck $ - MkTxSpec - { actions = - [ MkSomeCEMAction $ - MkCEMAction auctionParams Buyout - ] - , specSigner = bidder1 - } + Just (CurrentBid currentBid) <- queryScriptState auctionParams + liftIO $ currentBid `shouldBe` bid2 + + mEvent <- liftIO $ extractEvent @SimpleAuction network $ resolvedTxToOura preBody utxo + liftIO $ mEvent `shouldBe` Just (Following MakeBidSpine) + + (preBody, utxo) <- + submitCheckReturn $ + MkTxSpec + { actions = + [ MkSomeCEMAction $ + MkCEMAction auctionParams Close + ] + , specSigner = seller + } + + mEvent <- liftIO $ extractEvent @SimpleAuction network $ resolvedTxToOura preBody utxo + liftIO $ mEvent `shouldBe` Just (Following CloseSpine) + + (preBody, utxo) <- + submitCheckReturn $ + MkTxSpec + { actions = + [ MkSomeCEMAction $ + MkCEMAction auctionParams Buyout + ] + , specSigner = bidder1 + } + + mEvent <- liftIO $ extractEvent @SimpleAuction network $ resolvedTxToOura preBody utxo + liftIO $ mEvent `shouldBe` Just (Following BuyoutSpine) diff --git a/test/Main.hs b/test/Main.hs index 62e34c2..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) @@ -27,5 +27,5 @@ main = do 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 e5f9a34..0000000 --- a/test/Oura.hs +++ /dev/null @@ -1,116 +0,0 @@ -{-# 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..f55edfc 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, @@ -10,8 +18,8 @@ module Oura.Communication ( Interval (MkIntervalMs, unIntervalMs), ) where -import Prelude - +import Cardano.CEM.Indexing.Oura (SinkPath, SourcePath (MkSourcePath), unSinkPath) +import Cardano.CEM.Indexing.Oura qualified as Indexing import Control.Concurrent ( Chan, ThreadId, @@ -23,16 +31,113 @@ import Control.Concurrent ( threadDelay, writeList2Chan, ) -import Control.Monad (forever) +import Control.Concurrent.Async (Async) +import Control.Concurrent.Async qualified as Async +import Control.Monad (forever, void) +import Control.Monad.Cont (ContT (ContT, runContT)) +import Control.Monad.Trans (lift) import Data.ByteString qualified as BS +import Data.ByteString.Char8 qualified as BS.Char8 import Data.Foldable (for_) +import Data.String (IsString (fromString)) import Data.Text qualified as T +import Data.Text.IO qualified as T.IO import Data.Traversable (for) import Network.Socket qualified as Socket import Network.Socket.ByteString qualified as Socket.BS +import System.Directory (removeFile) +import System.Process qualified as Process +import Toml (Table) +import Utils (withNewFile) +import Utils qualified +import Prelude -import Cardano.CEM.Indexing (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 diff --git a/test/Oura/Config.hs b/test/Oura/Config.hs deleted file mode 100644 index 3ba63e3..0000000 --- a/test/Oura/Config.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# 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 a3cf75b..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 @@ -67,32 +68,34 @@ spec = makeConfig \oura -> do withTimeout 6.0 do + putStrLn "------------------------------" + print tx oura.send unmatchingTx 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 a05c8e6..67b2e37 100644 --- a/test/OuraFilters/Mock.hs +++ b/test/OuraFilters/Mock.hs @@ -6,261 +6,14 @@ module OuraFilters.Mock where -import Cardano.Api.SerialiseRaw qualified as SerialiseRaw -import Cardano.CEM.Address qualified as Address -import Cardano.Ledger.BaseTypes qualified as Ledger -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.Types -import Data.Base64.Types qualified as Base64 -import Data.Base64.Types qualified as Base64.Types 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.Functor ((<&>)) -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 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")] ''Multiasset - -data Redeemer = MkRedeemer - { _purpose :: Purpose - , payload :: PlutusData - } - deriving stock (Generic) - deriving (Aeson.ToJSON) via (WithoutUnderscore Redeemer) - deriving (Aeson.FromJSON) via (WithoutUnderscore Redeemer) -makeLenses ''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 - data TxEvent = MkTxEvent { _parsed_tx :: Tx , _point :: String -- "Origin" @@ -279,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 56% rename from test/OuraFilters.hs rename to test/OuraFilters/Simple.hs index c990d2b..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 @@ -94,8 +95,10 @@ ouraFiltersSpec = Utils.killProcessesOnError do Utils.withTimeout 3.0 do oura.send tx oura.send matchingTx - Right outTxHash <- - extractOutputTxHash <$> oura.receive + Right outTxHash <- do + bs <- oura.receive + print bs + pure $ extractOutputTxHash bs Right inputTxHash <- pure $ extractInputTxHash matchingTx outTxHash `shouldBe` inputTxHash diff --git a/test/Utils.hs b/test/Utils.hs index 8c22a46..7457007 100644 --- a/test/Utils.hs +++ b/test/Utils.hs @@ -1,27 +1,15 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BlockArguments #-} module Utils where import Prelude -import Data.Map (keys) -import Data.Map qualified as Map -import Data.Maybe (mapMaybe) - -import PlutusLedgerApi.V1.Interval (always) -import PlutusLedgerApi.V1.Value (assetClassValue) - import Cardano.Api hiding (queryUtxo) import Cardano.Api.Shelley ( PlutusScript (..), ReferenceScript (..), toMaryValue, ) - -import Test.Hspec (shouldSatisfy) -import Text.Show.Pretty (ppShow) - import Cardano.CEM.Monads ( BlockchainMonadEvent (..), CEMAction (..), @@ -40,21 +28,36 @@ import Cardano.CEM.OffChain ( awaitTx, fromPlutusAddressInMonad, resolveTxAndSubmit, + resolveTxAndSubmitRet, + ) +import Cardano.Extras ( + Era, + fromPlutusValue, + mintedTokens, + signingKeyToAddress, + tokenToAsset, + utxoValue, + withKeyWitness, ) -import Cardano.Extras -import Data.Spine (HasSpine (..)) - import Control.Exception (bracket) import Control.Monad ((<=<)) import Data.Aeson.Types qualified as Aeson import Data.Foldable (traverse_) import Data.IORef qualified as IORef +import Data.Map (keys) +import Data.Map qualified as Map +import Data.Maybe (mapMaybe) +import Data.Spine (HasSpine (..)) +import PlutusLedgerApi.V1.Interval (always) +import PlutusLedgerApi.V1.Value (assetClassValue) import System.Directory (removeFile) import System.IO (hClose, openTempFile) import System.Process qualified as Process import System.Timeout (timeout) +import Test.Hspec (shouldSatisfy) import Test.Hspec qualified as Hspec import TestNFT +import Text.Show.Pretty (ppShow) withTimeout :: (Hspec.HasCallStack) => Float -> IO a -> IO a withTimeout sec = @@ -65,21 +68,8 @@ 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 $ fromInteger 300_000_000 +execClb = execOnIsolatedClb $ lovelaceToValue 300_000_000 mintTestTokens :: (MonadIO m, MonadSubmitTx m) => SigningKey PaymentKey -> Integer -> m () @@ -96,12 +86,12 @@ mintTestTokens userSk numMint = do TxOut userAddress ( convert $ - ( fromPlutusValue $ - assetClassValue + fromPlutusValue + ( assetClassValue testNftAssetClass numMint - ) - <> (lovelaceToValue $ fromInteger 3_000_000) + ) + <> lovelaceToValue 3_000_000 ) TxOutDatumNone ReferenceScriptNone @@ -139,7 +129,6 @@ awaitEitherTx eitherTx = case eitherTx of Right txId -> do awaitTx txId - -- liftIO $ putStrLn $ "Awaited " <> show txId Left errorMsg -> error $ "Failed to send tx: " <> ppShow errorMsg submitAndCheck :: (MonadSubmitTx m, MonadIO m) => TxSpec -> m () @@ -149,6 +138,18 @@ submitAndCheck spec = do liftIO $ putStrLn $ " --> " <> show transition awaitEitherTx =<< resolveTxAndSubmit spec +submitCheckReturn :: + (MonadSubmitTx m, MonadIO m) => + TxSpec -> + m (TxBodyContent BuildTx Era, UTxO Era) +submitCheckReturn spec = do + case head $ actions spec of + MkSomeCEMAction (MkCEMAction _ transition) -> + liftIO $ putStrLn $ " --> " <> show transition + ~(Right (tbc, tb, _, utxo)) <- resolveTxAndSubmitRet spec + awaitTx $ getTxId tb + pure (tbc, utxo) + perTransitionStats :: (MonadBlockchainParams m) => m (Map.Map String Fees) perTransitionStats = do events <- eventList diff --git a/test/Voting.hs b/test/Voting.hs index 06be3bb..e62f1fe 100644 --- a/test/Voting.hs +++ b/test/Voting.hs @@ -1,24 +1,22 @@ module Voting (votingSpec) where -import Prelude hiding (readFile) - -import Control.Monad.IO.Class (MonadIO (..)) - -import Test.Hspec (describe, shouldBe) - import Cardano.CEM import Cardano.CEM.Examples.Compilation () import Cardano.CEM.Examples.Voting import Cardano.CEM.Monads import Cardano.CEM.OffChain import Cardano.Extras (signingKeyToPKH) - +import Control.Monad.IO.Class (MonadIO (..)) +import Test.Hspec (describe, shouldBe) import Utils +import Prelude hiding (readFile) votingSpec = describe "Voting" $ do let ignoreTest (_name :: String) = const (return ()) - -- FIXME: fix Voting budget or fix this issue https://github.com/mlabs-haskell/clb/issues/50 + -- TODO: fix Voting budget + -- https://github.com/mlabs-haskell/cem-script/issues/108 + -- https://github.com/mlabs-haskell/clb/issues/50 ignoreTest "Successfull flow" $ execClb $ do jury1 : jury2 : creator : _ <- getTestWalletSks