diff --git a/cem-script.cabal b/cem-script.cabal index 085126c..f2355d1 100644 --- a/cem-script.cabal +++ b/cem-script.cabal @@ -140,6 +140,7 @@ library hs-source-dirs: src/ exposed-modules: Cardano.CEM + Cardano.CEM.Address Cardano.CEM.Documentation Cardano.CEM.Examples.Auction Cardano.CEM.Examples.Compilation @@ -147,6 +148,7 @@ library Cardano.CEM.Monads Cardano.CEM.Monads.CLB Cardano.CEM.Monads.L1 + Cardano.CEM.OuraConfig Cardano.CEM.OffChain Cardano.CEM.OnChain Cardano.CEM.Stages @@ -158,6 +160,7 @@ library , cem-script:cardano-extras , cem-script:data-spine , clb + , toml-parser , dependent-map , ouroboros-consensus , QuickCheck @@ -178,6 +181,7 @@ test-suite cem-sdk-test , clb , dependent-map , hspec + , hspec-core , QuickCheck , quickcheck-dynamic , random @@ -186,6 +190,15 @@ test-suite cem-sdk-test , toml-parser , process , async + , lens + , aeson + , base64 + , cardano-api + , cardano-ledger-core + , vector + , safe + , base16 + , base32 hs-source-dirs: test/ other-modules: @@ -199,5 +212,7 @@ test-suite cem-sdk-test Oura.Communication Oura.Config OuraFilters + OuraFilters.Auction + OuraFilters.Mock main-is: Main.hs diff --git a/flake.lock b/flake.lock index ee36294..6b36aa7 100644 --- a/flake.lock +++ b/flake.lock @@ -94,17 +94,17 @@ "rust-overlay": "rust-overlay" }, "locked": { - "lastModified": 1722044885, - "narHash": "sha256-et0b5XyaWfpdcWtdx1+/kY6XtFYa2SBktIltYW0vTsI=", + "lastModified": 1726499628, + "narHash": "sha256-nFWhflLZyDaqlFebViZ241fnAIf2AwYBxXnJfaHUK7Y=", "owner": "Renegatto", "repo": "oura", - "rev": "3be6b2883d41ced958c4d462b5e899e05cdf9b6a", + "rev": "bfcac25065719f9e3405acbbdf5fe782846ddf32", "type": "github" }, "original": { "owner": "Renegatto", "repo": "oura", - "rev": "3be6b2883d41ced958c4d462b5e899e05cdf9b6a", + "rev": "bfcac25065719f9e3405acbbdf5fe782846ddf32", "type": "github" } }, diff --git a/flake.nix b/flake.nix index 5bebd0a..eb532fc 100644 --- a/flake.nix +++ b/flake.nix @@ -1,6 +1,6 @@ { inputs = { - raw-oura.url = "github:Renegatto/oura?rev=3be6b2883d41ced958c4d462b5e899e05cdf9b6a"; + raw-oura.url = "github:Renegatto/oura?rev=bfcac25065719f9e3405acbbdf5fe782846ddf32"; flake-utils.follows = "raw-oura/flake-utils"; rust-overlay.follows = "raw-oura/rust-overlay"; nixpkgs.follows = "raw-oura/nixpkgs"; diff --git a/matchingTx.json b/matchingTx.json deleted file mode 100644 index f658f5d..0000000 --- a/matchingTx.json +++ /dev/null @@ -1,64 +0,0 @@ -{ - "parsed_tx": { - "inputs": [ - { - "tx_hash": "af6366838cfac9cc56856ffe1d595ad1dd32c9bafb1ca064a08b5c687293110f", - "output_index": 5, - "as_output": { - - "address": "AZSTMVzZLrXYxDBOZ7fhauNtYdNFAmlGV4EaLI4ze2LP/2QDoGo6y8NPjEYAPGn+eaNijO+pxHJR", - "coin": 254564, - "assets": [], - "datum": null, - "datum_hash": "af6366838cfac9cc56856ffe1d595ad1dd32c9bafb1ca064a08b5c687293110f", - "script": null - }, - "redeemer": null - - } - ], - "outputs": [ - { - "address": "cM+tGRS1mdGL/9FNK71pYBnCiZy91qAzJc32gLw=", - "coin": 254564, - "assets": [], - "datum": null, - "datum_hash": "af6366838cfac9cc56856ffe1d595ad1dd32c9bafb1ca064a08b5c687293110f", - "script": null - } - ], - "certificates": [], - "withdrawals": [], - "mint": [], - "reference_inputs": [], - "witnesses": { - "vkeywitness": [], - "script": [], - "plutus_datums": [] - }, - "collateral": { - "collateral": [], - "collateral_return": { - "address": "cM+tGRS1mdGL/9FNK71pYBnCiZy91qAzJc32gLw=", - "coin": 254564, - "assets": [], - "datum": null, - "datum_hash": "af6366838cfac9cc56856ffe1d595ad1dd32c9bafb1ca064a08b5c687293110f", - "script": null - }, - "total_collateral": 2555 - }, - "fee": 967, - "validity": { - "start": 324, - "ttl": 323 - }, - "successful": true, - "auxiliary": { - "metadata": [], - "scripts": [] - }, - "hash": "af6366838cfac9cc56856ffe1d595ad1dd32c9bafb1ca064a08b5c687293110f" - }, - "point": "Origin" -} \ No newline at end of file diff --git a/oura.nix b/oura.nix index b28cdb8..3d05a6d 100644 --- a/oura.nix +++ b/oura.nix @@ -9,7 +9,7 @@ env = { OPENSSL_NO_VENDOR = "1"; # Use system openssl }; - nativeBuildInputs = [pkgs.pkg-config]; + nativeBuildInputs = [pkgs.pkg-config pkgs.m4]; buildInputs = [pkgs.openssl]; src = craneLib.cleanCargoSource inputs.oura; }; diff --git a/src/Cardano/CEM.hs b/src/Cardano/CEM.hs index 7bcc618..4f23cb4 100644 --- a/src/Cardano/CEM.hs +++ b/src/Cardano/CEM.hs @@ -14,11 +14,12 @@ import Data.Map qualified as Map import PlutusLedgerApi.V1.Address (Address, pubKeyHashAddress) import PlutusLedgerApi.V1.Crypto (PubKeyHash) import PlutusLedgerApi.V2 (ToData (..), Value) -import PlutusTx.Show.TH (deriveShow) +import PlutusTx.Show.TH qualified -- Project imports import Cardano.CEM.Stages import Data.Spine +import qualified PlutusTx.IsData.Class -- | This is different ways to specify address data AddressSpec @@ -34,17 +35,26 @@ addressSpecToAddress ownAddress addressSpec = case addressSpec of ByPubKey pubKey -> pubKeyHashAddress pubKey BySameScript -> ownAddress +-- "Tx Fan" - is transaction input or output + +-- FIXME: What is this? data TxFanFilter script = MkTxFanFilter { address :: AddressSpec - , rest :: TxFanFilter' script + , rest :: FilterDatum script } deriving stock (Show, Prelude.Eq) -data TxFanFilter' script - = Anything +-- This could only be a type alias +-- https://github.com/IntersectMBO/plutus/issues/5769 +type AsData a = BuiltinData + +-- | Tx Fan matches by +data FilterDatum script + = AnyDatum | -- | To be used via `bySameCem` - UnsafeBySameCEM BuiltinData - | ByDatum BuiltinData + -- Basically means "make new 'CEMScriptDatum' containing this State and then use with 'ByDatum'" + UnsafeBySameCEM (AsData (State script)) -- state part of a 'CEMScriptDatum' + | ByDatum (AsData (CEMScriptDatum script)) deriving stock (Show, Prelude.Eq) {-# INLINEABLE bySameCEM #-} @@ -53,20 +63,25 @@ data TxFanFilter' script bySameCEM :: (ToData (State script), CEMScript script) => State script -> - TxFanFilter' script + FilterDatum script bySameCEM = UnsafeBySameCEM . toBuiltinData -- TODO: use natural numbers -data Quantor = Exist Integer | SumValueEq Value +-- | How many tx fans should satify a 'TxFansConstraint' +data Quantifier + = ExactlyNFans Integer + | FansWithTotalValueOfAtLeast Value deriving stock (Show) +-- | A kind of Tx input our output data TxFanKind = In | InRef | Out deriving stock (Prelude.Eq, Prelude.Show) -data TxFanConstraint script = MkTxFanC - { txFanCKind :: TxFanKind - , txFanCFilter :: TxFanFilter script - , txFanCQuantor :: Quantor +-- | A constraint on Tx inputs or Outputs. +data TxFansConstraint script = MkTxFansC + { txFansCKind :: TxFanKind -- is constraint applies strictly on inputs or on outputs + , txFansCFilter :: TxFanFilter script -- constraint on a single tx fan + , txFansCQuantor :: Quantifier -- how much fans are required to match } deriving stock (Show) @@ -133,7 +148,7 @@ class Either BuiltinString (TransitionSpec script) data TransitionSpec script = MkTransitionSpec - { constraints :: [TxFanConstraint script] + { constraints :: [TxFansConstraint script] , -- List of additional signers (in addition to one required by TxIns) signers :: [PubKeyHash] } @@ -143,8 +158,8 @@ data TransitionSpec script = MkTransitionSpec getAllSpecSigners :: TransitionSpec script -> [PubKeyHash] getAllSpecSigners spec = signers spec ++ txInPKHs where - txInPKHs = mapMaybe getPubKey $ filter ((Prelude.== In) . txFanCKind) $ constraints spec - getPubKey c = case address (txFanCFilter c) of + txInPKHs = mapMaybe getPubKey $ filter ((Prelude.== In) . txFansCKind) $ constraints spec + getPubKey c = case address (txFansCFilter c) of ByPubKey key -> Just key _ -> Nothing @@ -160,10 +175,13 @@ deriving stock instance (CEMScript script) => (Show (CEMParams script)) deriving stock instance (CEMScript script) => (Prelude.Eq (CEMParams script)) -- FIXME: documentation +-- This can't be made anything than a tuple typealias because +-- of the Plutus compiler limitations: +-- https://github.com/IntersectMBO/plutus/issues/5769 type CEMScriptDatum script = (StageParams (Stage script), Params script, State script) -- TH deriving done at end of file for GHC staging reasons -deriveShow ''TxFanKind -deriveShow ''TxFanFilter' +PlutusTx.Show.TH.deriveShow ''TxFanKind +PlutusTx.Show.TH.deriveShow ''FilterDatum diff --git a/src/Cardano/CEM/Address.hs b/src/Cardano/CEM/Address.hs new file mode 100644 index 0000000..be8c6b5 --- /dev/null +++ b/src/Cardano/CEM/Address.hs @@ -0,0 +1,91 @@ +module Cardano.CEM.Address ( + cardanoAddressBech32, + scriptCardanoAddress, + plutusAddressToShelleyAddress, + AddressBech32 (MkAddressBech32, unAddressBech32), +) where + +import Cardano.Api qualified +import Cardano.Api.Address qualified +import Cardano.Api.Ledger qualified +import Cardano.CEM.OnChain qualified as Compiled +import Cardano.Crypto.Hash qualified as Cardano.Hash +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.String (IsString) +import Data.Text qualified as T +import Plutus.Extras qualified +import PlutusLedgerApi.V1 qualified +import Prelude + +newtype AddressBech32 = MkAddressBech32 {unAddressBech32 :: T.Text} + deriving newtype (Eq, Show, IsString) + +cardanoAddressBech32 :: Cardano.Api.Address Cardano.Api.ShelleyAddr -> AddressBech32 +cardanoAddressBech32 = MkAddressBech32 . Cardano.Api.serialiseToBech32 + +scriptCardanoAddress :: + forall script. + (Compiled.CEMScriptCompiled script) => + Proxy script -> + Cardano.Api.Ledger.Network -> + Either String (Cardano.Api.Address Cardano.Api.ShelleyAddr) +scriptCardanoAddress _ network = + plutusAddressToShelleyAddress network + . flip PlutusLedgerApi.V1.Address Nothing + . PlutusLedgerApi.V1.ScriptCredential + . Plutus.Extras.scriptValidatorHash + . Compiled.cemScriptCompiled + $ Proxy @script + +plutusAddressToShelleyAddress :: + Cardano.Api.Ledger.Network -> + PlutusLedgerApi.V1.Address -> + Either String (Cardano.Api.Address Cardano.Api.ShelleyAddr) +plutusAddressToShelleyAddress network (PlutusLedgerApi.V1.Address payment stake) = do + paymentCred <- + maybe + (Left "plutusAddressToShelleyAddress:can't decode payment credential") + Right + paymentCredential + stakeCred <- + maybe + (Left "plutusAddressToShelleyAddress:can't decode stake credential") + Right + stakeCredential + pure $ Cardano.Api.Address.ShelleyAddress network paymentCred stakeCred + where + credentialToCardano + ( PlutusLedgerApi.V1.PubKeyCredential + (PlutusLedgerApi.V1.PubKeyHash pkh) + ) = + Cred.KeyHashObj + . Ledger.Keys.KeyHash + <$> Cardano.Hash.hashFromBytes + (PlutusLedgerApi.V1.fromBuiltin pkh) + credentialToCardano + ( PlutusLedgerApi.V1.ScriptCredential + (PlutusLedgerApi.V1.ScriptHash scriptHash) + ) = + Cred.ScriptHashObj + . Cardano.Ledger.Hashes.ScriptHash + <$> Cardano.Hash.hashFromBytes + (PlutusLedgerApi.V1.fromBuiltin scriptHash) + + paymentCredential = credentialToCardano payment + stakeCredential = case stake of + Nothing -> Just Cardano.Api.Ledger.StakeRefNull + Just ref -> case ref of + PlutusLedgerApi.V1.StakingHash cred -> + Cardano.Api.Ledger.StakeRefBase + <$> credentialToCardano cred + PlutusLedgerApi.V1.StakingPtr slotNo txIx sertId -> + Just $ + Cardano.Api.Ledger.StakeRefPtr $ + Cred.Ptr + (Ledger.SlotNo $ fromInteger slotNo) + (Ledger.TxIx $ fromInteger txIx) + (Ledger.CertIx $ fromInteger sertId) diff --git a/src/Cardano/CEM/Examples/Auction.hs b/src/Cardano/CEM/Examples/Auction.hs index 3e69e04..7e62e46 100644 --- a/src/Cardano/CEM/Examples/Auction.hs +++ b/src/Cardano/CEM/Examples/Auction.hs @@ -91,10 +91,10 @@ instance CEMScript SimpleAuction where Right $ MkTransitionSpec { constraints = - [ MkTxFanC + [ MkTxFansC In - (MkTxFanFilter (ByPubKey $ seller params) Anything) - (SumValueEq $ lot params) + (MkTxFanFilter (ByPubKey $ seller params) AnyDatum) + (FansWithTotalValueOfAtLeast $ lot params) , nextState NotStarted ] , signers = [] @@ -126,18 +126,18 @@ instance CEMScript SimpleAuction where $ MkTransitionSpec { constraints = [ -- Example: In constraints redundant for on-chain - MkTxFanC + MkTxFansC In - (MkTxFanFilter (ByPubKey (better winnerBet)) Anything) - (SumValueEq $ betAdaValue winnerBet) - , MkTxFanC + (MkTxFanFilter (ByPubKey (better winnerBet)) AnyDatum) + (FansWithTotalValueOfAtLeast $ betAdaValue winnerBet) + , MkTxFansC Out - (MkTxFanFilter (ByPubKey (better winnerBet)) Anything) - (SumValueEq $ lot params) - , MkTxFanC + (MkTxFanFilter (ByPubKey (better winnerBet)) AnyDatum) + (FansWithTotalValueOfAtLeast $ lot params) + , MkTxFansC Out - (MkTxFanFilter (ByPubKey (seller params)) Anything) - (SumValueEq $ betAdaValue winnerBet) + (MkTxFanFilter (ByPubKey (seller params)) AnyDatum) + (FansWithTotalValueOfAtLeast $ betAdaValue winnerBet) ] , signers = [] } @@ -145,10 +145,10 @@ instance CEMScript SimpleAuction where where initialBid = MkBet (seller params) 0 nextState state' = - MkTxFanC + MkTxFansC Out (MkTxFanFilter BySameScript (bySameCEM state')) - (SumValueEq $ lot params) + (FansWithTotalValueOfAtLeast $ lot params) betAdaValue = adaValue . betAmount adaValue = singleton (CurrencySymbol emptyByteString) (TokenName emptyByteString) diff --git a/src/Cardano/CEM/Examples/Voting.hs b/src/Cardano/CEM/Examples/Voting.hs index a155e6b..ef243f2 100644 --- a/src/Cardano/CEM/Examples/Voting.hs +++ b/src/Cardano/CEM/Examples/Voting.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas -ddump-splices #-} {-# HLINT ignore "Use when" #-} @@ -134,10 +134,10 @@ instance CEMScript SimpleVoting where let allowedToVoteConstraints = case juryPolicy params of WithToken value -> - [ MkTxFanC + [ MkTxFansC InRef - (MkTxFanFilter (ByPubKey jury) Anything) - (SumValueEq value) + (MkTxFanFilter (ByPubKey jury) AnyDatum) + (FansWithTotalValueOfAtLeast value) ] _ -> [] @@ -160,4 +160,4 @@ instance CEMScript SimpleVoting where _ -> Left "Wrong state transition" where where nextScriptState state' = - MkTxFanC Out (MkTxFanFilter BySameScript (bySameCEM state')) (Exist 1) + MkTxFansC Out (MkTxFanFilter BySameScript (bySameCEM state')) (ExactlyNFans 1) diff --git a/src/Cardano/CEM/OffChain.hs b/src/Cardano/CEM/OffChain.hs index c4c5caf..d96a64a 100644 --- a/src/Cardano/CEM/OffChain.hs +++ b/src/Cardano/CEM/OffChain.hs @@ -147,7 +147,7 @@ resolveAction let byKind kind = - filter (\x -> txFanCKind x == kind) $ + filter (\x -> txFansCKind x == kind) $ constraints scriptTransition txInsPairs <- concat <$> mapM resolveTxIn (byKind In) @@ -166,22 +166,22 @@ resolveAction where script = cemScriptCompiled (Proxy :: Proxy script) scriptAddress = cemScriptAddress (Proxy :: Proxy script) - resolveTxIn (MkTxFanC _ (MkTxFanFilter addressSpec _) _) = do + resolveTxIn (MkTxFansC _ (MkTxFanFilter addressSpec _) _) = do utxo <- lift $ queryUtxo $ ByAddresses [address] return $ map (\(x, y) -> (withKeyWitness x, y)) $ Map.toList $ unUTxO utxo where address = addressSpecToAddress scriptAddress addressSpec compileTxConstraint - (MkTxFanC _ (MkTxFanFilter addressSpec filterSpec) quantor) = do + (MkTxFansC _ (MkTxFanFilter addressSpec filterSpec) quantor) = do address' <- lift $ fromPlutusAddressInMonad address let compiledTxOut value = TxOut address' value datum ReferenceScriptNone return $ case quantor of - Exist n -> replicate (fromInteger n) $ compiledTxOut minUtxoValue - SumValueEq value -> [compiledTxOut $ (convertTxOut $ fromPlutusValue value) <> minUtxoValue] + ExactlyNFans n -> replicate (fromInteger n) $ compiledTxOut minUtxoValue + FansWithTotalValueOfAtLeast value -> [compiledTxOut $ (convertTxOut $ fromPlutusValue value) <> minUtxoValue] where datum = case filterSpec of - Anything -> TxOutDatumNone + AnyDatum -> TxOutDatumNone ByDatum datum' -> mkInlineDatum datum' -- FIXME: Can be optimized via Plutarch UnsafeBySameCEM newState -> diff --git a/src/Cardano/CEM/OnChain.hs b/src/Cardano/CEM/OnChain.hs index 44ef329..ac9c8c8 100644 --- a/src/Cardano/CEM/OnChain.hs +++ b/src/Cardano/CEM/OnChain.hs @@ -74,7 +74,7 @@ genericCEMScript script scriptStage = let checkTxFan' filterSpec' fan = case filterSpec' of - Anything -> True + AnyDatum -> True UnsafeBySameCEM stateData -> let -- FIXUP: do not decode unnecessary @@ -93,7 +93,8 @@ genericCEMScript script scriptStage = getDatum datumContent == expectedDatum OutputDatumHash _ -> traceError "Hash datum not supported" _ -> False - checkConstraint (MkTxFanC fanKind filterSpec quantifier) = + -- given a fans constraint checks it against all fans + checkConstraint (MkTxFansC fanKind filterSpec quantifier) = traceIfFalse ("Checking constraint " <> show fanKind <> " " <> show datumSpec) $ checkQuantifier $ filter checkTxFan fans @@ -108,9 +109,9 @@ genericCEMScript script scriptStage = Out -> txInfoOutputs info checkQuantifier txFans = case quantifier of - SumValueEq value -> + FansWithTotalValueOfAtLeast value -> foldMap txOutValue txFans `geq` value - Exist n -> length txFans == n + ExactlyNFans n -> length txFans == n params :: Params $(conT script) stageParams :: StageParams ($(conT scriptStage)) diff --git a/src/Cardano/CEM/OuraConfig.hs b/src/Cardano/CEM/OuraConfig.hs new file mode 100644 index 0000000..04a0f81 --- /dev/null +++ b/src/Cardano/CEM/OuraConfig.hs @@ -0,0 +1,100 @@ +module Cardano.CEM.OuraConfig ( + SourcePath (MkSourcePath, unSourcePath), + SinkPath (MkSinkPath, unSinkPath), + Filter (MkFilter, unFilter), + daemonConfig, + selectByAddress, + ouraMonitoringScript, +) where + +import Cardano.CEM.Address qualified as Address +import Cardano.CEM.OnChain (CEMScriptCompiled) +import Cardano.Ledger.BaseTypes qualified as Ledger +import Data.Data (Proxy) +import Data.String (IsString) +import Data.Text qualified as T +import Toml qualified +import Toml.Schema ((.=)) +import Toml.Schema.ToValue qualified as Toml.ToValue +import Prelude + +newtype SourcePath = MkSourcePath {unSourcePath :: T.Text} + deriving newtype (IsString) + +newtype SinkPath = MkSinkPath {unSinkPath :: T.Text} + deriving newtype (IsString) + +newtype Filter = MkFilter {unFilter :: Toml.Table} + deriving newtype (Eq, Show) + +daemonConfig :: [Filter] -> SourcePath -> SinkPath -> Toml.Table +daemonConfig filters sourcePath sinkPath = + Toml.ToValue.table + [ "filters" .= Toml.List (Toml.Table . unFilter <$> filters) + , "cursor" .= cursor + , "intersect" .= intersect + , "sink" .= sink sinkPath + , "source" .= source sourcePath + ] + +-- | A oura *filter* that selects by address +selectByAddress :: Address.AddressBech32 -> Filter +selectByAddress (Address.MkAddressBech32 addressBech32) = + MkFilter $ + Toml.ToValue.table + [ "predicate" .= Toml.Text addressBech32 -- "addr1qx2fxv2umyhttkxyxp8x0dlpdt3k6cwng5pxj3jhsydzer3n0d3vllmyqwsx5wktcd8cc3sq835lu7drv2xwl2wywfgse35a3x" + , "skip_uncertain" .= Toml.Bool False + , "type" .= Toml.Text "Select" + ] + +-- | Makes an oura config such that oura is going to monitor all spendings from the script's payment credential. +ouraMonitoringScript :: + forall script. + (CEMScriptCompiled script) => + Proxy script -> + Ledger.Network -> + SourcePath -> + SinkPath -> + Either String Toml.Table +ouraMonitoringScript p network sourcePath sinkPath = + (\filters -> daemonConfig filters sourcePath sinkPath) + . pure + . selectByAddress + . Address.cardanoAddressBech32 + <$> Address.scriptCardanoAddress p network + +cursor :: Toml.Table +cursor = + Toml.ToValue.table + [ "path" .= Toml.Text "./oura-daemon-cursor" + , "type" .= Toml.Text "File" + ] + +intersect :: Toml.Table +intersect = + Toml.ToValue.table + [ "type" .= Toml.Text "Point" + , "value" + .= Toml.List + [ Toml.Integer 37225013 + , Toml.Text "65b3d40e6114e05b662ddde737da63bbab05b86d476148614e82cde98462a6f5" + ] + ] + +sink :: SinkPath -> Toml.Table +sink (MkSinkPath sinkPath) = + Toml.ToValue.table + [ "compress_files" .= Toml.Bool True + , "max_bytes_per_file" .= Toml.Integer 1_000_000 + , "max_total_files" .= Toml.Integer 10 + , "output_format" .= Toml.Text "JSONL" + , "output_path" .= Toml.Text sinkPath + , "type" .= Toml.Text "FileRotate" + ] + +source :: SourcePath -> Toml.Table +source (MkSourcePath socketPath) = + Toml.ToValue.table + [ "socket_path" .= Toml.Text socketPath + , "type" .= Toml.Text "TxOverSocket" + ] diff --git a/src/Cardano/CEM/Testing/StateMachine.hs b/src/Cardano/CEM/Testing/StateMachine.hs index 22265d8..caeec10 100644 --- a/src/Cardano/CEM/Testing/StateMachine.hs +++ b/src/Cardano/CEM/Testing/StateMachine.hs @@ -216,7 +216,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 (txFanCFilter c) of + decodeOutState c = case rest (txFansCFilter c) of UnsafeBySameCEM stateBS -> fromBuiltinData @(State script) stateBS _ -> Nothing diff --git a/test/Main.hs b/test/Main.hs index e8b3408..39cea37 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,16 +1,17 @@ {-# LANGUAGE BlockArguments #-} + module Main (main) where import Prelude -import Test.Hspec (hspec,runIO) +import Test.Hspec (hspec, runIO) import Auction (auctionSpec) import Dynamic (dynamicSpec) import OffChain (offChainSpec) import OuraFilters (ouraFiltersSpec) -import Voting (votingSpec) import Utils (clearLogs) +import Voting (votingSpec) main :: IO () main = hspec do diff --git a/test/Oura.hs b/test/Oura.hs index 099ba07..25e534c 100644 --- a/test/Oura.hs +++ b/test/Oura.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE OverloadedRecordDot #-} + module Oura ( WorkDir (MkWorkDir, unWorkDir), Oura (MkOura, send, receive, shutDown), @@ -18,24 +19,26 @@ import Data.Text qualified as T import Data.Text.IO qualified as T.IO import System.Process qualified as Process import Toml.Pretty qualified -import Utils qualified import Utils (withNewFile) +import Utils qualified -import Data.Text.Encoding qualified as Text.Encoding -import Oura.Communication qualified as Communication -import Oura.Config qualified as Config +import Cardano.CEM.OuraConfig qualified as Config import Control.Concurrent.Async (Async) import Control.Concurrent.Async qualified as Async +import Data.ByteString qualified as BS +import Oura.Communication qualified as Communication import System.Directory (removeFile) +import Toml (Table) --- | A time required for oura to start up and create a socket, --- in microseconds. +{- | 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 :: T.Text -> m () - , receive :: m T.Text + { send :: BS.ByteString -> m () + , receive :: m BS.ByteString , shutDown :: m () } newtype WorkDir = MkWorkDir {unWorkDir :: T.Text} @@ -44,17 +47,19 @@ newtype WorkDir = MkWorkDir {unWorkDir :: T.Text} withOura :: WorkDir -> Utils.SpotGarbage IO Process.ProcessHandle -> + (Config.SourcePath -> Config.SinkPath -> Table) -> (Oura IO -> IO r) -> IO r -withOura spotHandle workdir = - runContT $ runOura spotHandle workdir $ Just $ Communication.MkIntervalMs 1_000 +withOura spotHandle workdir makeConfig = + runContT $ runOura spotHandle workdir makeConfig $ Just $ Communication.MkIntervalMs 1_000 runOura :: WorkDir -> Utils.SpotGarbage IO Process.ProcessHandle -> + (Config.SourcePath -> Config.SinkPath -> Table) -> Maybe Communication.Interval -> ContT r IO (Oura IO) -runOura (MkWorkDir (T.unpack -> workdir)) spotHandle outputCheckingInterval = do +runOura (MkWorkDir (T.unpack -> workdir)) spotHandle makeConfig outputCheckingInterval = do writerPath <- ContT $ withNewFile "writer.socket" workdir @@ -68,7 +73,7 @@ runOura (MkWorkDir (T.unpack -> workdir)) spotHandle outputCheckingInterval = do withNewFile "source.socket" workdir lift $ removeFile $ T.unpack $ Config.unSourcePath sourcePath let - config = daemonConfig sourcePath sinkPath + config = configToText $ makeConfig sourcePath sinkPath configPath <- ContT $ withNewFile "config.toml" workdir lift $ T.IO.writeFile configPath config (ouraHandle, waitingForClose) <- launchOura configPath spotHandle @@ -87,13 +92,11 @@ runOura (MkWorkDir (T.unpack -> workdir)) spotHandle outputCheckingInterval = do Async.cancel waitingForClose Process.terminateProcess ouraHandle receive = Communication.waitForOutput ouraOutput - send = void - . Communication.sendToOura ouraConnection - . Text.Encoding.encodeUtf8 + send = void . Communication.sendToOura ouraConnection pure MkOura {shutDown, receive, send} -daemonConfig :: Config.SourcePath -> Config.SinkPath -> T.Text -daemonConfig = fmap (T.pack . show . Toml.Pretty.prettyToml) . Config.daemonConfig +configToText :: Table -> T.Text +configToText = T.pack . show . Toml.Pretty.prettyToml launchOura :: FilePath -> @@ -101,13 +104,14 @@ launchOura :: ContT r IO (Process.ProcessHandle, Async ()) launchOura configPath spotHandle = do ouraHandle <- lift do - ouraHandle <- Process.spawnProcess - "oura" - [ "daemon" - , "--config" - , configPath - ] - + ouraHandle <- + Process.spawnProcess + "oura" + [ "daemon" + , "--config" + , configPath + ] + void $ spotHandle.run ouraHandle pure ouraHandle diff --git a/test/Oura/Communication.hs b/test/Oura/Communication.hs index 78bb223..f71110e 100644 --- a/test/Oura/Communication.hs +++ b/test/Oura/Communication.hs @@ -27,13 +27,12 @@ import Control.Monad (forever) import Data.ByteString qualified as BS import Data.Foldable (for_) import Data.Text qualified as T -import Data.Text.Encoding qualified as Text.Encoding import Data.Traversable (for) import Network.Socket qualified as Socket import Network.Socket.ByteString qualified as Socket.BS -import Oura.Config (SinkPath, SourcePath (MkSourcePath), unSinkPath) - +import Cardano.CEM.OuraConfig (SinkPath, SourcePath (MkSourcePath), unSinkPath) +import Data.ByteString.Char8 qualified as BS.Char8 data OuraDaemonConnection = MkOuraDaemonConnection { ownSocket :: Socket.Socket @@ -73,7 +72,7 @@ close MkOuraDaemonConnection {ownSocket} = do -- * Consuming Oura output data OuraOutput = MkOuraOutput - { output :: Chan T.Text + { output :: Chan BS.ByteString , sinkPath :: SinkPath , monitor :: Maybe ThreadId } @@ -97,7 +96,7 @@ listenOuraSink sinkPath monitoringInterval = do stopMonitoring :: OuraOutput -> IO () stopMonitoring MkOuraOutput {monitor} = for_ monitor killThread -waitForOutput :: OuraOutput -> IO T.Text +waitForOutput :: OuraOutput -> IO BS.ByteString waitForOutput out@MkOuraOutput {output} = do collectOutput out readChan output @@ -113,4 +112,4 @@ collectOutput MkOuraOutput {output, sinkPath} = do let sink = T.unpack $ unSinkPath sinkPath contents <- BS.readFile sink BS.writeFile sink "" - writeList2Chan output $ reverse $ T.lines $ Text.Encoding.decodeUtf8 contents + writeList2Chan output $ reverse $ BS.Char8.lines contents diff --git a/test/Oura/Config.hs b/test/Oura/Config.hs index 7121b2c..513d493 100644 --- a/test/Oura/Config.hs +++ b/test/Oura/Config.hs @@ -1,74 +1,81 @@ +{-# LANGUAGE BlockArguments #-} + module Oura.Config ( - daemonConfig, - SourcePath (MkSourcePath, unSourcePath), - SinkPath (MkSinkPath, unSinkPath), + filtersL, + predicateL, + tableL, + atKey, + _Table, + _Integer, + _Bool, + _Text, ) where import Prelude -import Data.String (IsString) +import Cardano.CEM.OuraConfig 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 -import Toml.Schema.ToValue ((.=)) -import Toml.Schema.ToValue qualified as Toml.ToValue -- * Config -newtype SourcePath = MkSourcePath {unSourcePath :: T.Text} - deriving newtype (IsString) +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 -newtype SinkPath = MkSinkPath {unSinkPath :: T.Text} - deriving newtype (IsString) +_Text :: Prism' Toml.Value T.Text +_Text = prism' Toml.Text \case + Toml.Text t -> Just t + _ -> Nothing -daemonConfig :: SourcePath -> SinkPath -> Toml.Table -daemonConfig sourcePath sinkPath = - Toml.ToValue.table - [ "filters" .= Toml.List filters - , "cursor" .= cursor - , "intersect" .= intersect - , "sink" .= sink sinkPath - , "source" .= source sourcePath - ] +_List :: Prism' Toml.Value [Toml.Value] +_List = prism' Toml.List \case + Toml.List xs -> Just xs + _ -> Nothing -filters :: [Toml.Value] -filters = - [ Toml.Table $ - Toml.ToValue.table - [ "predicate" .= Toml.Text "addr1qx2fxv2umyhttkxyxp8x0dlpdt3k6cwng5pxj3jhsydzer3n0d3vllmyqwsx5wktcd8cc3sq835lu7drv2xwl2wywfgse35a3x" - , "skip_uncertain" .= Toml.Bool False - , "type" .= Toml.Text "Select" - ] - ] +_Bool :: Prism' Toml.Value Bool +_Bool = prism' Toml.Bool \case + Toml.Bool b -> Just b + _ -> Nothing -cursor :: Toml.Table -cursor = - Toml.ToValue.table - [ "path" .= Toml.Text "./oura-daemon-cursor" - , "type" .= Toml.Text "File" - ] -intersect :: Toml.Table -intersect = - Toml.ToValue.table - [ "type" .= Toml.Text "Point" - , "value" - .= Toml.List - [ Toml.Integer 37225013 - , Toml.Text "65b3d40e6114e05b662ddde737da63bbab05b86d476148614e82cde98462a6f5" - ] - ] -sink :: SinkPath -> Toml.Table -sink (MkSinkPath sinkPath) = - Toml.ToValue.table - [ "compress_files" .= Toml.Bool True - , "max_bytes_per_file" .= Toml.Integer 1_000_000 - , "max_total_files" .= Toml.Integer 10 - , "output_format" .= Toml.Text "JSONL" - , "output_path" .= Toml.Text sinkPath - , "type" .= Toml.Text "FileRotate" - ] -source :: SourcePath -> Toml.Table -source (MkSourcePath socketPath) = - Toml.ToValue.table - [ "socket_path" .= Toml.Text socketPath - , "type" .= Toml.Text "TxOverSocket" - ] +_Integer :: Prism' Toml.Value Integer +_Integer = prism' Toml.Integer \case + Toml.Integer n -> Just n + _ -> Nothing diff --git a/test/OuraFilters.hs b/test/OuraFilters.hs index 38530f3..8cc43e7 100644 --- a/test/OuraFilters.hs +++ b/test/OuraFilters.hs @@ -1,48 +1,115 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} module OuraFilters (ouraFiltersSpec) where -import Prelude -import Oura (Oura (send, receive, shutDown)) -import Oura qualified -import Test.Hspec (Spec, it, shouldBe) +import Cardano.CEM.OuraConfig qualified as Config +import Control.Lens (ix, (.~)) import Control.Monad ((>=>)) -import qualified Data.Text as T -import qualified Data.Text.IO as T.IO -import Utils qualified -import qualified Data.Aeson.Types as Aeson -import qualified Data.Aeson as Aeson import Data.Aeson ((.:)) +import Data.Aeson qualified as Aeson +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 OuraFilters.Auction qualified +import OuraFilters.Mock qualified as Mock +import PlutusLedgerApi.V1 qualified as V1 +import Test.Hspec (Spec, focus, it, shouldBe) +import Utils qualified +import Prelude + +exampleMatchingTx :: Mock.TxEvent +exampleMatchingTx = + exampleTx + & Mock.parsed_tx . Mock.inputs . ix 0 . Mock.as_output . Mock.address .~ inputAddress + where + inputAddress = Mock.MkAddressAsBase64 "AZSTMVzZLrXYxDBOZ7fhauNtYdNFAmlGV4EaLI4ze2LP/2QDoGo6y8NPjEYAPGn+eaNijO+pxHJR" -exampleTx :: IO T.Text -exampleTx = T.IO.readFile "./tx.json" +exampleFilter :: Config.Filter +exampleFilter = Config.selectByAddress "addr1qx2fxv2umyhttkxyxp8x0dlpdt3k6cwng5pxj3jhsydzer3n0d3vllmyqwsx5wktcd8cc3sq835lu7drv2xwl2wywfgse35a3x" -exampleMatchingTx :: IO T.Text -exampleMatchingTx = T.IO.readFile "./matchingTx.json" +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 = + Just $ + Mock.MkRedeemer + { _purpose = Mock.PURPOSE_UNSPECIFIED + , payload = Mock.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} + where + out = + Mock.MkTxOutput + { Mock._address = Mock.MkAddressAsBase64 "cM+tGRS1mdGL/9FNK71pYBnCiZy91qAzJc32gLw=" + , Mock._coin = 254564 + , Mock._assets = [] + , Mock._datum = + Just $ + Mock.MkDatum + { Mock._payload = + Mock.encodePlutusData $ + V1.List + [ V1.Map + [ (V1.I 2, V1.I 33) + ] + , V1.Constr 3 [V1.I 288] + , V1.I 34 + , V1.B "aboba" + ] + , Mock.hash = Mock.MkBlake2b255Hex "af6366838cfac9cc56856ffe1d595ad1dd32c9bafb1ca064a08b5c687293110f" + , Mock._original_cbor = "" + } + , Mock._script = Nothing + } ouraFiltersSpec :: Spec ouraFiltersSpec = Utils.killProcessesOnError do - it "Oura filters match tx it have to match, and don't match other" \spotGarbage -> do - Oura.withOura (Oura.MkWorkDir "./tmp") spotGarbage \oura -> do - tx <- exampleTx - matchingTx <- exampleMatchingTx - oura.send tx - -- _ <- oura.receive - oura.send matchingTx - Right outTxHash - <- extractOutputTxHash <$> oura.receive - Right inputTxHash - <- pure $ extractInputTxHash matchingTx - outTxHash `shouldBe` inputTxHash - oura.shutDown - -extractInputTxHash :: T.Text -> Either String T.Text -extractInputTxHash = Aeson.eitherDecodeStrictText >=> Aeson.parseEither \json -> do - parsedTx <- json .: "parsed_tx" - parsedTx .: "hash" - -extractOutputTxHash :: T.Text -> Either String T.Text -extractOutputTxHash = Aeson.eitherDecodeStrictText >=> Aeson.parseEither \json -> do - parsedTx <- json .: "record" - parsedTx .: "hash" \ No newline at end of file + focus $ it "Oura filters match tx it have to match, and don't match other" \spotGarbage -> + let + tx = Mock.txToBS exampleTx + matchingTx = Mock.txToBS exampleMatchingTx + in + Oura.withOura + (Oura.MkWorkDir "./tmp") + spotGarbage + (Config.daemonConfig [exampleFilter]) + \oura -> do + Utils.withTimeout 3.0 do + oura.send tx + oura.send matchingTx + Right outTxHash <- + extractOutputTxHash <$> oura.receive + Right inputTxHash <- + pure $ extractInputTxHash matchingTx + outTxHash `shouldBe` inputTxHash + oura.shutDown + OuraFilters.Auction.spec + +extractInputTxHash :: BS.ByteString -> Either String T.Text +extractInputTxHash = + Aeson.eitherDecodeStrict >=> Aeson.parseEither \json -> do + parsedTx <- json .: "parsed_tx" + parsedTx .: "hash" + +extractOutputTxHash :: BS.ByteString -> Either String T.Text +extractOutputTxHash = + Aeson.eitherDecodeStrict >=> Aeson.parseEither \json -> do + parsedTx <- json .: "record" + parsedTx .: "hash" diff --git a/test/OuraFilters/Auction.hs b/test/OuraFilters/Auction.hs new file mode 100644 index 0000000..610bea9 --- /dev/null +++ b/test/OuraFilters/Auction.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE OverloadedRecordDot #-} + +module OuraFilters.Auction (spec) where + +import Cardano.CEM.Examples.Auction qualified as Auction +import Cardano.CEM.Examples.Compilation () +import Cardano.CEM.OnChain qualified as Compiled +import Cardano.CEM.OuraConfig qualified as OuraConfig +import Cardano.Ledger.BaseTypes qualified as Ledger +import Control.Lens ((%~), (.~)) +import Control.Monad ((>=>)) +import Data.Aeson ((.:)) +import Data.Aeson qualified as Aeson +import Data.Aeson.Types qualified as Aeson.Types +import Data.ByteString qualified as BS +import Data.ByteString.Char8 qualified as BS.IO +import Data.Data (Proxy (Proxy)) +import Data.Text qualified as T +import Oura qualified +import OuraFilters.Mock qualified as Mock +import Plutus.Extras (scriptValidatorHash) +import PlutusLedgerApi.V1 qualified +import System.Process (ProcessHandle) +import Test.Hspec (describe, focus, it, shouldBe) +import Test.Hspec.Core.Spec (SpecM) +import Utils (SpotGarbage, withTimeout) +import Prelude + +spec :: SpecM (SpotGarbage IO ProcessHandle) () +spec = + describe "Auction example" do + focus $ it "Catches any Auction validator transition" \spotGarbage -> + let + auctionPaymentCredential = + PlutusLedgerApi.V1.ScriptCredential auctionValidatorHash + auctionValidatorHash = + scriptValidatorHash + . Compiled.cemScriptCompiled + $ Proxy @Auction.SimpleAuction + + -- we want oura to monitor just payment credential, ignoring stake credentials + arbitraryStakeCredential = PlutusLedgerApi.V1.StakingPtr 5 3 2 + + rightTxHash = + Mock.MkBlake2b255Hex + "2266778888888888888888888888888888888888888888888888444444444444" + inputFromValidator = + emptyInputFixture auctionPaymentCredential (Just arbitraryStakeCredential) + tx = + Mock.txToBS + . Mock.mkTxEvent + . (Mock.inputs %~ (inputFromValidator :)) + . (Mock.hash .~ rightTxHash) + $ Mock.arbitraryTx + unmatchingTx = + Mock.txToBS + . Mock.mkTxEvent + $ Mock.arbitraryTx + makeConfig source sink = + either error id $ + OuraConfig.ouraMonitoringScript (Proxy @Auction.SimpleAuction) Ledger.Mainnet source sink + in + do + Oura.withOura + (Oura.MkWorkDir "./tmp") + spotGarbage + makeConfig + \oura -> do + withTimeout 6.0 do + oura.send unmatchingTx + oura.send tx + msg <- oura.receive + txHash <- either error pure $ extractTxHash msg + Mock.MkBlake2b255Hex txHash `shouldBe` rightTxHash + oura.shutDown + +emptyInputFixture :: + PlutusLedgerApi.V1.Credential -> + Maybe PlutusLedgerApi.V1.StakingCredential -> + Mock.TxInput +emptyInputFixture paymentCred mstakeCred = + Mock.MkTxInput + { Mock._as_output = + Mock.MkTxOutput + { Mock._address = + Mock.plutusAddressToOuraAddress $ + PlutusLedgerApi.V1.Address paymentCred mstakeCred + , Mock._datum = Nothing + , Mock._coin = 2 + , Mock._script = Nothing + , Mock._assets = mempty + } + , Mock._tx_hash = Mock.MkBlake2b255Hex "af6366838cfac9cc56856ffe1d595ad1dd32c9bafb1ca064a08b5c687293110f" + , Mock._output_index = 0 + , Mock._redeemer = Nothing + } + +extractTxHash :: BS.ByteString -> Either String T.Text +extractTxHash = + Aeson.eitherDecodeStrict >=> Aeson.Types.parseEither \json -> do + parsedTx <- json .: "record" + parsedTx .: "hash" diff --git a/test/OuraFilters/Mock.hs b/test/OuraFilters/Mock.hs new file mode 100644 index 0000000..a05c8e6 --- /dev/null +++ b/test/OuraFilters/Mock.hs @@ -0,0 +1,371 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} + +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 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 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" + } + deriving stock (Generic) + deriving (Aeson.ToJSON) via (WithoutUnderscore TxEvent) + deriving (Aeson.FromJSON) via (WithoutUnderscore TxEvent) +makeLenses ''TxEvent + +mkTxEvent :: Tx -> TxEvent +mkTxEvent _parsed_tx = + MkTxEvent + { _parsed_tx + , _point = "Origin" + } + +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/Utils.hs b/test/Utils.hs index 9763343..65d1fa8 100644 --- a/test/Utils.hs +++ b/test/Utils.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BlockArguments #-} + module Utils where import Prelude @@ -43,13 +45,38 @@ 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 System.Directory (removeFile) import System.IO (hClose, openTempFile) +import System.Process qualified as Process +import System.Timeout (timeout) +import Test.Hspec qualified as Hspec import TestNFT -import Data.Foldable (traverse_) -import qualified Data.IORef as IORef -import qualified Test.Hspec as Hspec -import qualified System.Process as Process + +withTimeout :: (Hspec.HasCallStack) => Float -> IO a -> IO a +withTimeout sec = + maybe (error "Failed by timeout") pure + <=< timeout (round $ sec * 10 ** 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 $ fromInteger 300_000_000 @@ -162,7 +189,7 @@ debug msg = do -- * Janitor newtype SpotGarbage m a = MkSpotGarbage - { run :: a -> m a } + {run :: a -> m a} data Janitor m a = MkJanitor { cleanup :: m () @@ -170,18 +197,21 @@ data Janitor m a = MkJanitor } -- Note, that the cleanup process may fail in this implementation -newJanitor :: forall a. +newJanitor :: + forall a. (a -> IO ()) -> IO (Janitor IO a) newJanitor trash = do spottedGarbageRef <- IORef.newIORef [] - pure MkJanitor - { spotGarbage = MkSpotGarbage \garbage -> do - IORef.modifyIORef spottedGarbageRef (garbage :) - pure garbage - , cleanup = IORef.readIORef spottedGarbageRef - >>= traverse_ trash - } + pure + MkJanitor + { spotGarbage = MkSpotGarbage \garbage -> do + IORef.modifyIORef spottedGarbageRef (garbage :) + pure garbage + , cleanup = + IORef.readIORef spottedGarbageRef + >>= traverse_ trash + } cleanupAround :: (a -> IO ()) -> @@ -189,17 +219,17 @@ cleanupAround :: Hspec.SpecWith b -> Hspec.Spec cleanupAround trash toTestArg = - Hspec.around - $ bracket (newJanitor trash) cleanup - . flip fmap toTestArg - --- | This is a workaround the bug that cabal test can't finish before all its spawned processes --- no matter what. --- The workaround is to collect process handles and terminate them on error, allowing --- test suite to finish. + Hspec.around $ + bracket (newJanitor trash) cleanup + . flip fmap toTestArg + +{- | This is a workaround the bug that cabal test can't finish before all its spawned processes +no matter what. +The workaround is to collect process handles and terminate them on error, allowing +test suite to finish. +-} killProcessesOnError :: Hspec.SpecWith (SpotGarbage IO Process.ProcessHandle) -> Hspec.Spec killProcessesOnError = - cleanupAround Process.terminateProcess spotGarbage - + cleanupAround Process.terminateProcess spotGarbage diff --git a/tx.json b/tx.json deleted file mode 100644 index 24877dc..0000000 --- a/tx.json +++ /dev/null @@ -1,64 +0,0 @@ -{ - "parsed_tx": { - "inputs": [ - { - "tx_hash": "af6366838cfac9cc56856ffe1d595ad1dd32c9bafb1ca064a08b5c687293110f", - "output_index": 5, - "as_output": { - - "address": "cM+tGRS1mdGL/9FNK71pYBnCiZy91qAzJc32gLw=", - "coin": 254564, - "assets": [], - "datum": null, - "datum_hash": "af6366838cfac9cc56856ffe1d595ad1dd32c9bafb1ca064a08b5c687293110f", - "script": null - }, - "redeemer": null - - } - ], - "outputs": [ - { - "address": "cM+tGRS1mdGL/9FNK71pYBnCiZy91qAzJc32gLw=", - "coin": 254564, - "assets": [], - "datum": null, - "datum_hash": "af6366838cfac9cc56856ffe1d595ad1dd32c9bafb1ca064a08b5c687293110f", - "script": null - } - ], - "certificates": [], - "withdrawals": [], - "mint": [], - "reference_inputs": [], - "witnesses": { - "vkeywitness": [], - "script": [], - "plutus_datums": [] - }, - "collateral": { - "collateral": [], - "collateral_return": { - "address": "cM+tGRS1mdGL/9FNK71pYBnCiZy91qAzJc32gLw=", - "coin": 254564, - "assets": [], - "datum": null, - "datum_hash": "af6366838cfac9cc56856ffe1d595ad1dd32c9bafb1ca064a08b5c687293110f", - "script": null - }, - "total_collateral": 2555 - }, - "fee": 967, - "validity": { - "start": 324, - "ttl": 323 - }, - "successful": true, - "auxiliary": { - "metadata": [], - "scripts": [] - }, - "hash": "af6366838cfac9cc56856ffe1d595ad1dd32c9bafb1ca064a08b5c687293110f" - }, - "point": "Origin" -} \ No newline at end of file