From cab25929223a311355437069a70e7cfad34731bd Mon Sep 17 00:00:00 2001 From: Renegatto Date: Thu, 22 Aug 2024 18:12:21 +0300 Subject: [PATCH 01/36] Make a separate dir for mocks --- matchingTx.json => mocks/matchingTx.json | 0 tx.json => mocks/tx.json | 0 test/OuraFilters.hs | 4 ++-- 3 files changed, 2 insertions(+), 2 deletions(-) rename matchingTx.json => mocks/matchingTx.json (100%) rename tx.json => mocks/tx.json (100%) diff --git a/matchingTx.json b/mocks/matchingTx.json similarity index 100% rename from matchingTx.json rename to mocks/matchingTx.json diff --git a/tx.json b/mocks/tx.json similarity index 100% rename from tx.json rename to mocks/tx.json diff --git a/test/OuraFilters.hs b/test/OuraFilters.hs index 38530f3..b7a47f6 100644 --- a/test/OuraFilters.hs +++ b/test/OuraFilters.hs @@ -16,10 +16,10 @@ import qualified Data.Aeson as Aeson import Data.Aeson ((.:)) exampleTx :: IO T.Text -exampleTx = T.IO.readFile "./tx.json" +exampleTx = T.IO.readFile "./mock/tx.json" exampleMatchingTx :: IO T.Text -exampleMatchingTx = T.IO.readFile "./matchingTx.json" +exampleMatchingTx = T.IO.readFile "./mock/matchingTx.json" ouraFiltersSpec :: Spec ouraFiltersSpec = Utils.killProcessesOnError do From fffde346a753644db3c9057f085f1708e8bba1e9 Mon Sep 17 00:00:00 2001 From: Renegatto Date: Thu, 22 Aug 2024 18:12:51 +0300 Subject: [PATCH 02/36] Create placeholders for AuctionExample oura tests --- test/OuraFilters.hs | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/test/OuraFilters.hs b/test/OuraFilters.hs index b7a47f6..a5d9b33 100644 --- a/test/OuraFilters.hs +++ b/test/OuraFilters.hs @@ -6,7 +6,7 @@ module OuraFilters (ouraFiltersSpec) where import Prelude import Oura (Oura (send, receive, shutDown)) import Oura qualified -import Test.Hspec (Spec, it, shouldBe) +import Test.Hspec (Spec, it, shouldBe, describe) import Control.Monad ((>=>)) import qualified Data.Text as T import qualified Data.Text.IO as T.IO @@ -36,6 +36,17 @@ ouraFiltersSpec = Utils.killProcessesOnError do <- pure $ extractInputTxHash matchingTx outTxHash `shouldBe` inputTxHash oura.shutDown + describe "Auction example" do + it "Recognizes 'Create' transition" \_ -> do + fail @IO @() "Not implemented" + it "Recognizes 'Start' transition" \_ -> do + fail @IO @() "Not implemented" + it "Recognizes 'MakeBid' transition" \_ -> do + fail @IO @() "Not implemented" + it "Recognizes 'Close' transition" \_ -> do + fail @IO @() "Not implemented" + it "Recognizes 'Buyout' transition" \_ -> do + fail @IO @() "Not implemented" extractInputTxHash :: T.Text -> Either String T.Text extractInputTxHash = Aeson.eitherDecodeStrictText >=> Aeson.parseEither \json -> do From 0134438512bcf64e6141085d51b24fc7e564303c Mon Sep 17 00:00:00 2001 From: Renegatto Date: Thu, 22 Aug 2024 21:05:03 +0300 Subject: [PATCH 03/36] Rename TxFanConstraint into TxFansConstraint, document code --- src/Cardano/CEM.hs | 20 ++++++++++++-------- src/Cardano/CEM/Examples/Auction.hs | 10 +++++----- src/Cardano/CEM/Examples/Voting.hs | 4 ++-- src/Cardano/CEM/OffChain.hs | 6 +++--- src/Cardano/CEM/OnChain.hs | 3 ++- src/Cardano/CEM/Testing/StateMachine.hs | 2 +- 6 files changed, 25 insertions(+), 20 deletions(-) diff --git a/src/Cardano/CEM.hs b/src/Cardano/CEM.hs index 7bcc618..cef9112 100644 --- a/src/Cardano/CEM.hs +++ b/src/Cardano/CEM.hs @@ -34,6 +34,8 @@ addressSpecToAddress ownAddress addressSpec = case addressSpec of ByPubKey pubKey -> pubKeyHashAddress pubKey BySameScript -> ownAddress +-- "Tx Fan" - is transaction input or output + data TxFanFilter script = MkTxFanFilter { address :: AddressSpec , rest :: TxFanFilter' script @@ -57,16 +59,18 @@ bySameCEM :: bySameCEM = UnsafeBySameCEM . toBuiltinData -- TODO: use natural numbers -data Quantor = Exist Integer | SumValueEq Value +-- | How many tx fans should satify a 'TxFansConstraint' +data Quantifier = Exist Integer | SumValueEq Value deriving stock (Show) 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 +137,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 +147,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 diff --git a/src/Cardano/CEM/Examples/Auction.hs b/src/Cardano/CEM/Examples/Auction.hs index 3e69e04..4230392 100644 --- a/src/Cardano/CEM/Examples/Auction.hs +++ b/src/Cardano/CEM/Examples/Auction.hs @@ -91,7 +91,7 @@ instance CEMScript SimpleAuction where Right $ MkTransitionSpec { constraints = - [ MkTxFanC + [ MkTxFansC In (MkTxFanFilter (ByPubKey $ seller params) Anything) (SumValueEq $ lot params) @@ -126,15 +126,15 @@ 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 + , MkTxFansC Out (MkTxFanFilter (ByPubKey (better winnerBet)) Anything) (SumValueEq $ lot params) - , MkTxFanC + , MkTxFansC Out (MkTxFanFilter (ByPubKey (seller params)) Anything) (SumValueEq $ betAdaValue winnerBet) @@ -145,7 +145,7 @@ instance CEMScript SimpleAuction where where initialBid = MkBet (seller params) 0 nextState state' = - MkTxFanC + MkTxFansC Out (MkTxFanFilter BySameScript (bySameCEM state')) (SumValueEq $ lot params) diff --git a/src/Cardano/CEM/Examples/Voting.hs b/src/Cardano/CEM/Examples/Voting.hs index a155e6b..37c3d02 100644 --- a/src/Cardano/CEM/Examples/Voting.hs +++ b/src/Cardano/CEM/Examples/Voting.hs @@ -134,7 +134,7 @@ instance CEMScript SimpleVoting where let allowedToVoteConstraints = case juryPolicy params of WithToken value -> - [ MkTxFanC + [ MkTxFansC InRef (MkTxFanFilter (ByPubKey jury) Anything) (SumValueEq 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')) (Exist 1) diff --git a/src/Cardano/CEM/OffChain.hs b/src/Cardano/CEM/OffChain.hs index c4c5caf..c14c0bb 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,13 +166,13 @@ 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 diff --git a/src/Cardano/CEM/OnChain.hs b/src/Cardano/CEM/OnChain.hs index 44ef329..f68a049 100644 --- a/src/Cardano/CEM/OnChain.hs +++ b/src/Cardano/CEM/OnChain.hs @@ -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 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 From 04f7bd9049a3f04c812981c33b5bb8e5157f1fba Mon Sep 17 00:00:00 2001 From: Renegatto Date: Tue, 3 Sep 2024 20:28:28 +0300 Subject: [PATCH 04/36] Make identifiers them more descriptive --- src/Cardano/CEM.hs | 39 ++++++++++++++++++------- src/Cardano/CEM/Examples/Auction.hs | 18 ++++++------ src/Cardano/CEM/Examples/Voting.hs | 8 ++--- src/Cardano/CEM/OffChain.hs | 8 ++--- src/Cardano/CEM/OnChain.hs | 12 ++++---- src/Cardano/CEM/Testing/StateMachine.hs | 2 +- 6 files changed, 52 insertions(+), 35 deletions(-) diff --git a/src/Cardano/CEM.hs b/src/Cardano/CEM.hs index cef9112..face2b1 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 @@ -36,17 +37,30 @@ addressSpecToAddress ownAddress addressSpec = case addressSpec of -- "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 +newtype AsData a = MkAsData { unAsData :: BuiltinData } + deriving newtype + ( Prelude.Show + , Eq + , Prelude.Eq + , PlutusTx.Show.TH.Show + , PlutusTx.IsData.Class.FromData + , PlutusTx.IsData.Class.ToData + ) + +-- | 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 #-} @@ -55,14 +69,17 @@ data TxFanFilter' script bySameCEM :: (ToData (State script), CEMScript script) => State script -> - TxFanFilter' script -bySameCEM = UnsafeBySameCEM . toBuiltinData + FilterDatum script +bySameCEM = UnsafeBySameCEM . MkAsData . toBuiltinData -- TODO: use natural numbers -- | How many tx fans should satify a 'TxFansConstraint' -data Quantifier = Exist Integer | SumValueEq Value +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) @@ -169,5 +186,5 @@ type CEMScriptDatum 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/Examples/Auction.hs b/src/Cardano/CEM/Examples/Auction.hs index 4230392..7e62e46 100644 --- a/src/Cardano/CEM/Examples/Auction.hs +++ b/src/Cardano/CEM/Examples/Auction.hs @@ -93,8 +93,8 @@ instance CEMScript SimpleAuction where { constraints = [ MkTxFansC In - (MkTxFanFilter (ByPubKey $ seller params) Anything) - (SumValueEq $ lot params) + (MkTxFanFilter (ByPubKey $ seller params) AnyDatum) + (FansWithTotalValueOfAtLeast $ lot params) , nextState NotStarted ] , signers = [] @@ -128,16 +128,16 @@ instance CEMScript SimpleAuction where [ -- Example: In constraints redundant for on-chain MkTxFansC In - (MkTxFanFilter (ByPubKey (better winnerBet)) Anything) - (SumValueEq $ betAdaValue winnerBet) + (MkTxFanFilter (ByPubKey (better winnerBet)) AnyDatum) + (FansWithTotalValueOfAtLeast $ betAdaValue winnerBet) , MkTxFansC Out - (MkTxFanFilter (ByPubKey (better winnerBet)) Anything) - (SumValueEq $ lot params) + (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 = [] } @@ -148,7 +148,7 @@ instance CEMScript SimpleAuction where 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 37c3d02..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" #-} @@ -136,8 +136,8 @@ instance CEMScript SimpleVoting where WithToken value -> [ 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' = - MkTxFansC 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 c14c0bb..cea4227 100644 --- a/src/Cardano/CEM/OffChain.hs +++ b/src/Cardano/CEM/OffChain.hs @@ -177,11 +177,11 @@ resolveAction 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 -> @@ -190,7 +190,7 @@ resolveAction cemDatum = ( stagesParams params , scriptParams params - , unsafeFromBuiltinData newState + , unsafeFromBuiltinData (unAsData newState) ) in mkInlineDatum cemDatum diff --git a/src/Cardano/CEM/OnChain.hs b/src/Cardano/CEM/OnChain.hs index f68a049..a1dd0b8 100644 --- a/src/Cardano/CEM/OnChain.hs +++ b/src/Cardano/CEM/OnChain.hs @@ -74,14 +74,14 @@ genericCEMScript script scriptStage = let checkTxFan' filterSpec' fan = case filterSpec' of - Anything -> True - UnsafeBySameCEM stateData -> + AnyDatum -> True + UnsafeBySameCEM (MkAsData stateData) -> let -- FIXUP: do not decode unnecessary changedState = unsafeFromBuiltinData stateData :: State $(conT script) stateChangeDatum = (stageParams, params, stateData) - stateChangeDatumBS = toBuiltinData stateChangeDatum + stateChangeDatumBS = MkAsData (toBuiltinData stateChangeDatum) in checkTxFan' (ByDatum stateChangeDatumBS) fan ByDatum expectedDatum -> @@ -90,7 +90,7 @@ genericCEMScript script scriptStage = in case datum of OutputDatum datumContent -> - getDatum datumContent == expectedDatum + MkAsData (getDatum datumContent) == expectedDatum OutputDatumHash _ -> traceError "Hash datum not supported" _ -> False -- given a fans constraint checks it against all fans @@ -109,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/Testing/StateMachine.hs b/src/Cardano/CEM/Testing/StateMachine.hs index caeec10..8b5e54f 100644 --- a/src/Cardano/CEM/Testing/StateMachine.hs +++ b/src/Cardano/CEM/Testing/StateMachine.hs @@ -218,7 +218,7 @@ instance (CEMScriptArbitrary script) => StateModel (ScriptState script) where outStates spec = mapMaybe decodeOutState $ constraints spec decodeOutState c = case rest (txFansCFilter c) of UnsafeBySameCEM stateBS -> - fromBuiltinData @(State script) stateBS + fromBuiltinData @(State script) (unAsData stateBS) _ -> Nothing nextState _ _ _ = error "Unreachable" From 08037875a2022e3dfd309784b4e73ca2d848ba1b Mon Sep 17 00:00:00 2001 From: Renegatto Date: Thu, 5 Sep 2024 15:15:38 +0300 Subject: [PATCH 05/36] Remove newtype as it can't be compiled by Plutus --- src/Cardano/CEM.hs | 17 +++++++---------- src/Cardano/CEM/OffChain.hs | 2 +- src/Cardano/CEM/OnChain.hs | 6 +++--- src/Cardano/CEM/Testing/StateMachine.hs | 2 +- 4 files changed, 12 insertions(+), 15 deletions(-) diff --git a/src/Cardano/CEM.hs b/src/Cardano/CEM.hs index face2b1..4f23cb4 100644 --- a/src/Cardano/CEM.hs +++ b/src/Cardano/CEM.hs @@ -44,15 +44,9 @@ data TxFanFilter script = MkTxFanFilter } deriving stock (Show, Prelude.Eq) -newtype AsData a = MkAsData { unAsData :: BuiltinData } - deriving newtype - ( Prelude.Show - , Eq - , Prelude.Eq - , PlutusTx.Show.TH.Show - , PlutusTx.IsData.Class.FromData - , PlutusTx.IsData.Class.ToData - ) +-- 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 @@ -70,7 +64,7 @@ bySameCEM :: (ToData (State script), CEMScript script) => State script -> FilterDatum script -bySameCEM = UnsafeBySameCEM . MkAsData . toBuiltinData +bySameCEM = UnsafeBySameCEM . toBuiltinData -- TODO: use natural numbers -- | How many tx fans should satify a 'TxFansConstraint' @@ -181,6 +175,9 @@ 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) diff --git a/src/Cardano/CEM/OffChain.hs b/src/Cardano/CEM/OffChain.hs index cea4227..d96a64a 100644 --- a/src/Cardano/CEM/OffChain.hs +++ b/src/Cardano/CEM/OffChain.hs @@ -190,7 +190,7 @@ resolveAction cemDatum = ( stagesParams params , scriptParams params - , unsafeFromBuiltinData (unAsData newState) + , unsafeFromBuiltinData newState ) in mkInlineDatum cemDatum diff --git a/src/Cardano/CEM/OnChain.hs b/src/Cardano/CEM/OnChain.hs index a1dd0b8..ac9c8c8 100644 --- a/src/Cardano/CEM/OnChain.hs +++ b/src/Cardano/CEM/OnChain.hs @@ -75,13 +75,13 @@ genericCEMScript script scriptStage = checkTxFan' filterSpec' fan = case filterSpec' of AnyDatum -> True - UnsafeBySameCEM (MkAsData stateData) -> + UnsafeBySameCEM stateData -> let -- FIXUP: do not decode unnecessary changedState = unsafeFromBuiltinData stateData :: State $(conT script) stateChangeDatum = (stageParams, params, stateData) - stateChangeDatumBS = MkAsData (toBuiltinData stateChangeDatum) + stateChangeDatumBS = toBuiltinData stateChangeDatum in checkTxFan' (ByDatum stateChangeDatumBS) fan ByDatum expectedDatum -> @@ -90,7 +90,7 @@ genericCEMScript script scriptStage = in case datum of OutputDatum datumContent -> - MkAsData (getDatum datumContent) == expectedDatum + getDatum datumContent == expectedDatum OutputDatumHash _ -> traceError "Hash datum not supported" _ -> False -- given a fans constraint checks it against all fans diff --git a/src/Cardano/CEM/Testing/StateMachine.hs b/src/Cardano/CEM/Testing/StateMachine.hs index 8b5e54f..caeec10 100644 --- a/src/Cardano/CEM/Testing/StateMachine.hs +++ b/src/Cardano/CEM/Testing/StateMachine.hs @@ -218,7 +218,7 @@ instance (CEMScriptArbitrary script) => StateModel (ScriptState script) where outStates spec = mapMaybe decodeOutState $ constraints spec decodeOutState c = case rest (txFansCFilter c) of UnsafeBySameCEM stateBS -> - fromBuiltinData @(State script) (unAsData stateBS) + fromBuiltinData @(State script) stateBS _ -> Nothing nextState _ _ _ = error "Unreachable" From c7d664a6bca81e64b5c7071be662bf389cd70eb1 Mon Sep 17 00:00:00 2001 From: Renegatto Date: Thu, 5 Sep 2024 17:13:35 +0300 Subject: [PATCH 06/36] Make test placeholder --- cem-script.cabal | 2 ++ test/OuraFilters.hs | 21 ++++++--------------- test/OuraFilters/Auction.hs | 21 +++++++++++++++++++++ 3 files changed, 29 insertions(+), 15 deletions(-) create mode 100644 test/OuraFilters/Auction.hs diff --git a/cem-script.cabal b/cem-script.cabal index 085126c..f1febf1 100644 --- a/cem-script.cabal +++ b/cem-script.cabal @@ -178,6 +178,7 @@ test-suite cem-sdk-test , clb , dependent-map , hspec + , hspec-core , QuickCheck , quickcheck-dynamic , random @@ -199,5 +200,6 @@ test-suite cem-sdk-test Oura.Communication Oura.Config OuraFilters + OuraFilters.Auction main-is: Main.hs diff --git a/test/OuraFilters.hs b/test/OuraFilters.hs index a5d9b33..1877eb2 100644 --- a/test/OuraFilters.hs +++ b/test/OuraFilters.hs @@ -6,7 +6,7 @@ module OuraFilters (ouraFiltersSpec) where import Prelude import Oura (Oura (send, receive, shutDown)) import Oura qualified -import Test.Hspec (Spec, it, shouldBe, describe) +import Test.Hspec (Spec, it, focus, shouldBe, describe) import Control.Monad ((>=>)) import qualified Data.Text as T import qualified Data.Text.IO as T.IO @@ -14,16 +14,17 @@ import Utils qualified import qualified Data.Aeson.Types as Aeson import qualified Data.Aeson as Aeson import Data.Aeson ((.:)) +import OuraFilters.Auction qualified exampleTx :: IO T.Text -exampleTx = T.IO.readFile "./mock/tx.json" +exampleTx = T.IO.readFile "./mocks/tx.json" exampleMatchingTx :: IO T.Text -exampleMatchingTx = T.IO.readFile "./mock/matchingTx.json" +exampleMatchingTx = T.IO.readFile "./mocks/matchingTx.json" ouraFiltersSpec :: Spec ouraFiltersSpec = Utils.killProcessesOnError do - it "Oura filters match tx it have to match, and don't match other" \spotGarbage -> do + focus $ 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 @@ -36,17 +37,7 @@ ouraFiltersSpec = Utils.killProcessesOnError do <- pure $ extractInputTxHash matchingTx outTxHash `shouldBe` inputTxHash oura.shutDown - describe "Auction example" do - it "Recognizes 'Create' transition" \_ -> do - fail @IO @() "Not implemented" - it "Recognizes 'Start' transition" \_ -> do - fail @IO @() "Not implemented" - it "Recognizes 'MakeBid' transition" \_ -> do - fail @IO @() "Not implemented" - it "Recognizes 'Close' transition" \_ -> do - fail @IO @() "Not implemented" - it "Recognizes 'Buyout' transition" \_ -> do - fail @IO @() "Not implemented" + OuraFilters.Auction.spec extractInputTxHash :: T.Text -> Either String T.Text extractInputTxHash = Aeson.eitherDecodeStrictText >=> Aeson.parseEither \json -> do diff --git a/test/OuraFilters/Auction.hs b/test/OuraFilters/Auction.hs new file mode 100644 index 0000000..b5742d2 --- /dev/null +++ b/test/OuraFilters/Auction.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE BlockArguments #-} +module OuraFilters.Auction (spec) where +import Prelude +import Utils (SpotGarbage) +import System.Process (ProcessHandle) +import Test.Hspec (describe, it, focus) +import Test.Hspec.Core.Spec (SpecM) + +spec :: SpecM (SpotGarbage IO ProcessHandle) () +spec = + describe "Auction example" do + focus $ it "Recognizes 'Create' transition" \spotGarbage -> do + fail @IO @() "Not implemented" + it "Recognizes 'Start' transition" \spotGarbage -> do + fail @IO @() "Not implemented" + it "Recognizes 'MakeBid' transition" \spotGarbage -> do + fail @IO @() "Not implemented" + it "Recognizes 'Close' transition" \spotGarbage -> do + fail @IO @() "Not implemented" + it "Recognizes 'Buyout' transition" \spotGarbage -> do + fail @IO @() "Not implemented" \ No newline at end of file From dbb92856aa41c0c8804e5460a9e21b4da05d162a Mon Sep 17 00:00:00 2001 From: Renegatto Date: Thu, 5 Sep 2024 18:16:37 +0300 Subject: [PATCH 07/36] Make type for a mock oura data --- cem-script.cabal | 3 ++ test/OuraFilters/Mock.hs | 84 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 87 insertions(+) create mode 100644 test/OuraFilters/Mock.hs diff --git a/cem-script.cabal b/cem-script.cabal index f1febf1..d7569e0 100644 --- a/cem-script.cabal +++ b/cem-script.cabal @@ -187,6 +187,8 @@ test-suite cem-sdk-test , toml-parser , process , async + , lens + , aeson hs-source-dirs: test/ other-modules: @@ -201,5 +203,6 @@ test-suite cem-sdk-test Oura.Config OuraFilters OuraFilters.Auction + OuraFilters.Mock main-is: Main.hs diff --git a/test/OuraFilters/Mock.hs b/test/OuraFilters/Mock.hs new file mode 100644 index 0000000..dc2fae0 --- /dev/null +++ b/test/OuraFilters/Mock.hs @@ -0,0 +1,84 @@ +module OuraFilters.Mock where +import Prelude +import Control.Lens.TH (makeLenses) +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Aeson as Aeson + +newtype Address = MkBech32AsBase32 { base32bech32addr :: LBS.ByteString } +makeLenses ''Address + +newtype Hash32 = Mk32BitBase16Hash { unHash32 :: LBS.ByteString } +makeLenses ''Hash32 + +data TxOutput = MkTxOutput + { address :: Address + , coin :: Integer + , assets :: [Aeson.Value] + , datum :: Maybe Aeson.Value + , datum_hash :: Hash32 + , script :: Maybe Aeson.Value + } +makeLenses ''TxOutput + +data TxInput = MkTxInput + { tx_hash :: Hash32 + , output_index :: Integer + , as_output :: TxOutput + , redeemer :: Maybe Aeson.Value + } +makeLenses ''TxInput + +data TxWitnesses = MkTxWitnesses + { vkeywitness :: [Aeson.Value] + , script :: [Aeson.Value] + , plutus_datums :: [Aeson.Value] + } +makeLenses ''TxWitnesses + +data TxCollateral = MkTxCollateral + { collateral :: [Aeson.Value] + , collateral_return :: TxOutput + , total_collateral :: Integer + } +makeLenses ''TxCollateral + +data TxValidity = MkTxValidity + { start :: Integer + , ttl :: Integer + } +makeLenses ''TxValidity + +data TxAuxiliary = MkTxAuxiliary + { metadata :: [Aeson.Value] + , scripts :: [Aeson.Value] + } +makeLenses ''TxAuxiliary + +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 + } +makeLenses ''Tx + +data TxEvent = MkTxEvent + { parsed_tx :: Tx + , point :: String -- "Origin" + } +makeLenses ''TxEvent + +mkTxEvent :: Tx -> TxEvent +mkTxEvent parsed_tx = MkTxEvent + { parsed_tx + , point = "Origin" + } \ No newline at end of file From 0c4f8ecd055826dc9a9bd74f7bef81dc07b713fe Mon Sep 17 00:00:00 2001 From: Renegatto Date: Thu, 5 Sep 2024 21:35:50 +0300 Subject: [PATCH 08/36] Express existing mocks on haskell --- mocks/matchingTx.json | 64 -------------- mocks/tx.json | 64 -------------- test/OuraFilters.hs | 46 ++++++++-- test/OuraFilters/Mock.hs | 183 ++++++++++++++++++++++++++++++--------- 4 files changed, 179 insertions(+), 178 deletions(-) delete mode 100644 mocks/matchingTx.json delete mode 100644 mocks/tx.json diff --git a/mocks/matchingTx.json b/mocks/matchingTx.json deleted file mode 100644 index f658f5d..0000000 --- a/mocks/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/mocks/tx.json b/mocks/tx.json deleted file mode 100644 index 24877dc..0000000 --- a/mocks/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 diff --git a/test/OuraFilters.hs b/test/OuraFilters.hs index 1877eb2..abc5d1a 100644 --- a/test/OuraFilters.hs +++ b/test/OuraFilters.hs @@ -6,28 +6,58 @@ module OuraFilters (ouraFiltersSpec) where import Prelude import Oura (Oura (send, receive, shutDown)) import Oura qualified -import Test.Hspec (Spec, it, focus, shouldBe, describe) +import Test.Hspec (Spec, it, focus, shouldBe) 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 OuraFilters.Auction qualified +import qualified OuraFilters.Mock as Mock +import Data.Function ((&)) +import Control.Lens ((.~), ix) -exampleTx :: IO T.Text -exampleTx = T.IO.readFile "./mocks/tx.json" +exampleMatchingTx :: Mock.TxEvent +exampleMatchingTx = + exampleTx + & Mock.parsed_tx . Mock.inputs . ix 0 . Mock.as_output . Mock.address .~ inputAddress + where + inputAddress = Mock.MkBech32AsBase32 "AZSTMVzZLrXYxDBOZ7fhauNtYdNFAmlGV4EaLI4ze2LP/2QDoGo6y8NPjEYAPGn+eaNijO+pxHJR" -exampleMatchingTx :: IO T.Text -exampleMatchingTx = T.IO.readFile "./mocks/matchingTx.json" +exampleTx :: Mock.TxEvent +exampleTx = Mock.mkTxEvent $ Mock.arbitraryTx + & Mock.inputs .~ [ + Mock.MkTxInput + { Mock._tx_hash = Mock.Mk32BitBase16Hash "af6366838cfac9cc56856ffe1d595ad1dd32c9bafb1ca064a08b5c687293110f" + , Mock._output_index = 5 + , Mock._as_output = out + , Mock._redeemer = Nothing + } + ] + & Mock.outputs .~ [out] + & Mock.collateralL . Mock.collateral_return . Mock.coin .~ 25464 + & Mock.collateralL . Mock.total_collateral .~ 2555 + & Mock.fee .~ 967 + & Mock.validity .~ Mock.MkTxValidity { Mock._start = 324, Mock._ttl = 323 } + + where + out = Mock.MkTxOutput + { Mock._address = Mock.MkBech32AsBase32 "cM+tGRS1mdGL/9FNK71pYBnCiZy91qAzJc32gLw=" + , Mock._coin = 254564 + , Mock._assets = [] + , Mock._datum = Nothing + , Mock._datum_hash = Mock.Mk32BitBase16Hash "af6366838cfac9cc56856ffe1d595ad1dd32c9bafb1ca064a08b5c687293110f" + , Mock._script = Nothing + } ouraFiltersSpec :: Spec ouraFiltersSpec = Utils.killProcessesOnError do focus $ 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 + let + tx = Mock.txToText exampleTx + matchingTx = Mock.txToText exampleMatchingTx oura.send tx -- _ <- oura.receive oura.send matchingTx diff --git a/test/OuraFilters/Mock.hs b/test/OuraFilters/Mock.hs index dc2fae0..0567ea7 100644 --- a/test/OuraFilters/Mock.hs +++ b/test/OuraFilters/Mock.hs @@ -1,84 +1,183 @@ +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} +{-# LANGUAGE DuplicateRecordFields, NoFieldSelectors #-} module OuraFilters.Mock where import Prelude -import Control.Lens.TH (makeLenses) +import Control.Lens.TH (makeLenses, makeLensesFor) import qualified Data.ByteString.Lazy as LBS import qualified Data.Aeson as Aeson +import qualified Data.Text as T +import qualified Data.Text.Encoding as T.Encoding +import GHC.Generics (Generic (Rep)) -newtype Address = MkBech32AsBase32 { base32bech32addr :: LBS.ByteString } +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 = MkBech32AsBase32 T.Text + deriving newtype Aeson.ToJSON + deriving newtype Aeson.FromJSON makeLenses ''Address -newtype Hash32 = Mk32BitBase16Hash { unHash32 :: LBS.ByteString } +newtype Hash32 = Mk32BitBase16Hash T.Text + deriving newtype Aeson.ToJSON + deriving newtype Aeson.FromJSON makeLenses ''Hash32 data TxOutput = MkTxOutput - { address :: Address - , coin :: Integer - , assets :: [Aeson.Value] - , datum :: Maybe Aeson.Value - , datum_hash :: Hash32 - , script :: Maybe Aeson.Value + { _address :: Address + , _coin :: Integer + , _assets :: [Aeson.Value] + , _datum :: Maybe Aeson.Value + , _datum_hash :: Hash32 + , _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 Aeson.Value + { _tx_hash :: Hash32 + , _output_index :: Integer + , _as_output :: TxOutput + , _redeemer :: Maybe Aeson.Value } + 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] + { _vkeywitness :: [Aeson.Value] + , _script :: [Aeson.Value] + , _plutus_datums :: [Aeson.Value] } -makeLenses ''TxWitnesses + deriving stock Generic + deriving Aeson.ToJSON via (WithoutUnderscore TxWitnesses) + deriving Aeson.FromJSON via (WithoutUnderscore TxWitnesses) +-- makeLenses ''TxWitnesses data TxCollateral = MkTxCollateral - { collateral :: [Aeson.Value] - , collateral_return :: TxOutput - , total_collateral :: Integer + { _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 + { _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] + { _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 = MkBech32AsBase32 "cM+tGRS1mdGL/9FNK71pYBnCiZy91qAzJc32gLw=" + , _coin = 0 + , _assets = [] + , _datum = Nothing + , _datum_hash = Mk32BitBase16Hash "af6366838cfac9cc56856ffe1d595ad1dd32c9bafb1ca064a08b5c687293110f" + , _script = Nothing + } + , _total_collateral = 0 + } + , _fee = 0 + , _validity = MkTxValidity + { _start = 0 + , _ttl = 0 + } + , _successful = True + , _auxiliary = MkTxAuxiliary + { _metadata = [] + , _scripts = [] + } + , _hash = Mk32BitBase16Hash "af6366838cfac9cc56856ffe1d595ad1dd32c9bafb1ca064a08b5c687293110f" + } + + data Tx = MkTx - { inputs :: [TxInput] - , outputs :: [TxOutput] - , certificates :: [Aeson.Value] - , withdrawals :: [Aeson.Value] - , mint :: [Aeson.Value] - , reference_inputs :: [Aeson.Value] - , witnesses :: TxWitnesses + { _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 + , _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","collateralL")] ''Tx data TxEvent = MkTxEvent - { parsed_tx :: Tx - , point :: String -- "Origin" + { _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" - } \ No newline at end of file +mkTxEvent _parsed_tx = MkTxEvent + { _parsed_tx + , _point = "Origin" + } + + +txToText :: TxEvent -> T.Text +txToText = T.Encoding.decodeUtf8 + . LBS.toStrict + . Aeson.encode \ No newline at end of file From 13fd381dcf651caf4b1501b8041caf4a66f41870 Mon Sep 17 00:00:00 2001 From: Renegatto Date: Tue, 10 Sep 2024 18:49:25 +0300 Subject: [PATCH 09/36] De/serialize plutus addresses --- cem-script.cabal | 3 ++ test/OuraFilters.hs | 9 +++--- test/OuraFilters/Auction.hs | 62 +++++++++++++++++++++++++++++++++++-- test/OuraFilters/Mock.hs | 38 ++++++++++++++++++----- 4 files changed, 97 insertions(+), 15 deletions(-) diff --git a/cem-script.cabal b/cem-script.cabal index d7569e0..d977220 100644 --- a/cem-script.cabal +++ b/cem-script.cabal @@ -189,6 +189,9 @@ test-suite cem-sdk-test , async , lens , aeson + , base64 + , cardano-api + , cardano-ledger-core hs-source-dirs: test/ other-modules: diff --git a/test/OuraFilters.hs b/test/OuraFilters.hs index abc5d1a..8116546 100644 --- a/test/OuraFilters.hs +++ b/test/OuraFilters.hs @@ -23,7 +23,7 @@ exampleMatchingTx = exampleTx & Mock.parsed_tx . Mock.inputs . ix 0 . Mock.as_output . Mock.address .~ inputAddress where - inputAddress = Mock.MkBech32AsBase32 "AZSTMVzZLrXYxDBOZ7fhauNtYdNFAmlGV4EaLI4ze2LP/2QDoGo6y8NPjEYAPGn+eaNijO+pxHJR" + inputAddress = Mock.MkAddressAsBase64 "AZSTMVzZLrXYxDBOZ7fhauNtYdNFAmlGV4EaLI4ze2LP/2QDoGo6y8NPjEYAPGn+eaNijO+pxHJR" exampleTx :: Mock.TxEvent exampleTx = Mock.mkTxEvent $ Mock.arbitraryTx @@ -36,18 +36,17 @@ exampleTx = Mock.mkTxEvent $ Mock.arbitraryTx } ] & Mock.outputs .~ [out] - & Mock.collateralL . Mock.collateral_return . Mock.coin .~ 25464 - & Mock.collateralL . Mock.total_collateral .~ 2555 + & 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.MkBech32AsBase32 "cM+tGRS1mdGL/9FNK71pYBnCiZy91qAzJc32gLw=" + { Mock._address = Mock.MkAddressAsBase64 "cM+tGRS1mdGL/9FNK71pYBnCiZy91qAzJc32gLw=" , Mock._coin = 254564 , Mock._assets = [] , Mock._datum = Nothing - , Mock._datum_hash = Mock.Mk32BitBase16Hash "af6366838cfac9cc56856ffe1d595ad1dd32c9bafb1ca064a08b5c687293110f" , Mock._script = Nothing } diff --git a/test/OuraFilters/Auction.hs b/test/OuraFilters/Auction.hs index b5742d2..7e6d226 100644 --- a/test/OuraFilters/Auction.hs +++ b/test/OuraFilters/Auction.hs @@ -1,10 +1,32 @@ {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE PackageImports #-} module OuraFilters.Auction (spec) where import Prelude import Utils (SpotGarbage) import System.Process (ProcessHandle) -import Test.Hspec (describe, it, focus) +import Test.Hspec (describe, it, focus, HasCallStack) import Test.Hspec.Core.Spec (SpecM) +import qualified OuraFilters.Mock as Mock +import Data.Function ((&)) +import Cardano.CEM.Examples.Auction (SimpleAuctionState(NotStarted)) +import qualified Cardano.CEM.Examples.Auction as Auction +import qualified PlutusLedgerApi.V1 +import Control.Arrow ((>>>)) +import qualified PlutusTx.AssocMap as AssocMap +import Data.Functor ((<&>)) +import qualified Data.Text.Encoding as T.Encoding +import "cardano-api" Cardano.Api.Address qualified as Address +import qualified Cardano.Api.SerialiseRaw as SerialiseRaw +import qualified Cardano.Ledger.BaseTypes as Ledger +import qualified Cardano.Ledger.Credential as Cred +import qualified Cardano.Ledger.Keys as Ledger.Keys +import qualified Cardano.Crypto.Hash as Cardano.Hash +import Data.Maybe (fromJust) +import qualified Cardano.Api.Ledger +import qualified Cardano.Ledger.Hashes +import qualified Data.Base64.Types as Base64 +import qualified Data.ByteString.Base64 as BS.Base64 spec :: SpecM (SpotGarbage IO ProcessHandle) () spec = @@ -18,4 +40,40 @@ spec = it "Recognizes 'Close' transition" \spotGarbage -> do fail @IO @() "Not implemented" it "Recognizes 'Buyout' transition" \spotGarbage -> do - fail @IO @() "Not implemented" \ No newline at end of file + fail @IO @() "Not implemented" + +plutusAaddressToOuraAddress :: HasCallStack => PlutusLedgerApi.V1.Address -> Mock.Address +plutusAaddressToOuraAddress ( PlutusLedgerApi.V1.Address payment stake) = + Mock.MkAddressAsBase64 + $ Base64.extractBase64 + $ BS.Base64.encodeBase64 + $ SerialiseRaw.serialiseToRawBytes + $ Address.ShelleyAddress + Ledger.Mainnet + (fromJust paymentCredential) + (fromJust stakeCredential) + 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 {} -> + error "Staking pointers are not supported" diff --git a/test/OuraFilters/Mock.hs b/test/OuraFilters/Mock.hs index 0567ea7..302769b 100644 --- a/test/OuraFilters/Mock.hs +++ b/test/OuraFilters/Mock.hs @@ -26,9 +26,7 @@ instance toJSON = Aeson.genericToJSON withoutLeadingUnderscore instance (Generic a, Aeson.GFromJSON Aeson.Zero (Rep a)) => Aeson.FromJSON (WithoutUnderscore a) where parseJSON = Aeson.genericParseJSON withoutLeadingUnderscore - - -newtype Address = MkBech32AsBase32 T.Text +newtype Address = MkAddressAsBase64 T.Text deriving newtype Aeson.ToJSON deriving newtype Aeson.FromJSON makeLenses ''Address @@ -38,12 +36,36 @@ newtype Hash32 = Mk32BitBase16Hash T.Text deriving newtype Aeson.FromJSON makeLenses ''Hash32 +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 :: T.Text + , assets :: [Asset] + , redeemer :: Maybe Aeson.Value + } + deriving stock Generic + deriving Aeson.ToJSON via (WithoutUnderscore Multiasset) + deriving Aeson.FromJSON via (WithoutUnderscore Multiasset) +makeLenses ''Multiasset +makeLensesFor + [ ("assets","multiassetAssets") + , ("redeemer","multiassetRedeemer") + ] + ''Multiasset + data TxOutput = MkTxOutput { _address :: Address , _coin :: Integer - , _assets :: [Aeson.Value] + , _assets :: [Multiasset] , _datum :: Maybe Aeson.Value - , _datum_hash :: Hash32 , _script :: Maybe Aeson.Value } deriving stock Generic @@ -116,11 +138,10 @@ arbitraryTx = MkTx , collateral = MkTxCollateral { _collateral = [] , _collateral_return = MkTxOutput - { _address = MkBech32AsBase32 "cM+tGRS1mdGL/9FNK71pYBnCiZy91qAzJc32gLw=" + { _address = MkAddressAsBase64 "cM+tGRS1mdGL/9FNK71pYBnCiZy91qAzJc32gLw=" , _coin = 0 , _assets = [] , _datum = Nothing - , _datum_hash = Mk32BitBase16Hash "af6366838cfac9cc56856ffe1d595ad1dd32c9bafb1ca064a08b5c687293110f" , _script = Nothing } , _total_collateral = 0 @@ -139,6 +160,7 @@ arbitraryTx = MkTx } +-- Source: https://docs.rs/utxorpc-spec/latest/utxorpc_spec/utxorpc/v1alpha/cardano/struct.Tx.html data Tx = MkTx { _inputs :: [TxInput] , _outputs :: [TxOutput] @@ -158,7 +180,7 @@ data Tx = MkTx deriving Aeson.ToJSON via (WithoutUnderscore Tx) deriving Aeson.FromJSON via (WithoutUnderscore Tx) makeLenses ''Tx -makeLensesFor [("collateral","collateralL")] ''Tx +makeLensesFor [("collateral","txCollateral")] ''Tx data TxEvent = MkTxEvent { _parsed_tx :: Tx From 36d09c3718b811d15e8ff8d8d4b461482e5dbd8b Mon Sep 17 00:00:00 2001 From: Renegatto Date: Tue, 10 Sep 2024 18:50:14 +0300 Subject: [PATCH 10/36] Create auction mock Tx WIP --- test/OuraFilters/Auction.hs | 48 +++++++++++++++++++++++++++++++++++++ 1 file changed, 48 insertions(+) diff --git a/test/OuraFilters/Auction.hs b/test/OuraFilters/Auction.hs index 7e6d226..8508331 100644 --- a/test/OuraFilters/Auction.hs +++ b/test/OuraFilters/Auction.hs @@ -32,6 +32,12 @@ spec :: SpecM (SpotGarbage IO ProcessHandle) () spec = describe "Auction example" do focus $ it "Recognizes 'Create' transition" \spotGarbage -> do + let + addr = PlutusLedgerApi.V1.Address + (PlutusLedgerApi.V1.PubKeyCredential + (PlutusLedgerApi.V1.PubKeyHash "e628bfd68c07a7a38fcd7d8df650812a9dfdbee54b1ed4c25c87ffbf")) + Nothing + print $ PlutusLedgerApi.V1.toBuiltinData addr fail @IO @() "Not implemented" it "Recognizes 'Start' transition" \spotGarbage -> do fail @IO @() "Not implemented" @@ -77,3 +83,45 @@ plutusAaddressToOuraAddress ( PlutusLedgerApi.V1.Address payment stake) = <$> credentialToCardano cred PlutusLedgerApi.V1.StakingPtr {} -> error "Staking pointers are not supported" + +createTxMock :: Auction.SimpleAuctionParams -> Mock.Tx +createTxMock params = Mock.arbitraryTx + & undefined + where + input = Mock.MkTxInput + { Mock._as_output = Mock.MkTxOutput + { Mock._address = + plutusAaddressToOuraAddress + $ PlutusLedgerApi.V1.Address + (PlutusLedgerApi.V1.PubKeyCredential params.seller) + Nothing + , Mock._datum = Nothing -- any datum + , Mock._coin = 2 + , Mock._script = Nothing + , Mock._assets = valueToMultiAsset params.lot + } + , Mock._tx_hash = Mock.Mk32BitBase16Hash "af6366838cfac9cc56856ffe1d595ad1dd32c9bafb1ca064a08b5c687293110f" + , Mock._output_index = 0 + , Mock._redeemer = undefined + } + valueToMultiAsset :: PlutusLedgerApi.V1.Value -> [Mock.Multiasset] + valueToMultiAsset = + PlutusLedgerApi.V1.getValue >>> AssocMap.toList >>> fmap \(cs,tokens) -> + Mock.MkMultiasset + { Mock._policy_id = + T.Encoding.decodeUtf8 + $ PlutusLedgerApi.V1.fromBuiltin + $ PlutusLedgerApi.V1.unCurrencySymbol cs + , Mock.assets = AssocMap.toList tokens <&> \(tn,amt) -> + Mock.MkAsset + { Mock._name = T.Encoding.decodeUtf8 + $ PlutusLedgerApi.V1.fromBuiltin + $ PlutusLedgerApi.V1.unTokenName tn + , Mock._output_coin = amt -- positive + , Mock._mint_coin = 1 + } + , Mock.redeemer = Nothing + } + + inputState = Nothing + outputState = Just NotStarted \ No newline at end of file From 3be398aeb20effe22e35ec281d558fbc8c8fae6a Mon Sep 17 00:00:00 2001 From: Renegatto Date: Thu, 12 Sep 2024 15:36:36 +0300 Subject: [PATCH 11/36] Debug utxoRPC encoding --- cem-script.cabal | 1 + test/OuraFilters/Mock.hs | 95 +++++++++++++++++++++++++++++++++++----- test/Utils.hs | 11 +++++ 3 files changed, 97 insertions(+), 10 deletions(-) diff --git a/cem-script.cabal b/cem-script.cabal index d977220..6dce400 100644 --- a/cem-script.cabal +++ b/cem-script.cabal @@ -192,6 +192,7 @@ test-suite cem-sdk-test , base64 , cardano-api , cardano-ledger-core + , vector hs-source-dirs: test/ other-modules: diff --git a/test/OuraFilters/Mock.hs b/test/OuraFilters/Mock.hs index 302769b..be05ee0 100644 --- a/test/OuraFilters/Mock.hs +++ b/test/OuraFilters/Mock.hs @@ -1,19 +1,29 @@ {-# OPTIONS_GHC -Wno-partial-type-signatures #-} {-# LANGUAGE DuplicateRecordFields, NoFieldSelectors #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE AllowAmbiguousTypes #-} module OuraFilters.Mock where import Prelude import Control.Lens.TH (makeLenses, makeLensesFor) -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Aeson as Aeson -import qualified Data.Text as T -import qualified Data.Text.Encoding as T.Encoding +import Data.ByteString.Lazy qualified as LBS +import Data.Aeson qualified as Aeson +import Data.Text qualified as T +import Data.Text.Encoding qualified as T.Encoding import GHC.Generics (Generic (Rep)) +import PlutusLedgerApi.V1 qualified +import Data.Aeson (KeyValue((.=))) +import Data.Vector qualified as Vec +import Data.Functor ((<&>)) +import Data.ByteString qualified as BS +import Data.ByteString.Base64 qualified as Base64 +import Data.Base64.Types qualified as Base64.Types +import Utils (digits) newtype WithoutUnderscore a = MkWithoutUnderscore a deriving newtype Generic withoutLeadingUnderscore :: Aeson.Options -withoutLeadingUnderscore = +withoutLeadingUnderscore = Aeson.defaultOptions { Aeson.fieldLabelModifier = \case '_':fieldName -> fieldName @@ -61,11 +71,27 @@ makeLensesFor ] ''Multiasset +newtype PlutusData = MkPlutusData { _plutusData :: Aeson.Value } + deriving newtype Generic + deriving newtype (Aeson.FromJSON, Aeson.ToJSON) +makeLenses ''PlutusData + +data Datum = MkDatum + { hash :: Hash32 + , _payload :: Maybe PlutusData + , _original_cbor :: T.Text + } + deriving stock Generic + deriving Aeson.ToJSON via (WithoutUnderscore Datum) + deriving Aeson.FromJSON via (WithoutUnderscore Datum) +makeLenses ''Datum +makeLensesFor [("hash","datum_hash")] ''Datum + data TxOutput = MkTxOutput { _address :: Address , _coin :: Integer , _assets :: [Multiasset] - , _datum :: Maybe Aeson.Value + , _datum :: Maybe PlutusData , _script :: Maybe Aeson.Value } deriving stock Generic @@ -77,7 +103,7 @@ data TxInput = MkTxInput { _tx_hash :: Hash32 , _output_index :: Integer , _as_output :: TxOutput - , _redeemer :: Maybe Aeson.Value + , _redeemer :: Maybe Datum } deriving stock Generic deriving Aeson.ToJSON via (WithoutUnderscore TxInput) @@ -87,7 +113,7 @@ makeLenses ''TxInput data TxWitnesses = MkTxWitnesses { _vkeywitness :: [Aeson.Value] , _script :: [Aeson.Value] - , _plutus_datums :: [Aeson.Value] + , _plutus_datums :: [Datum] } deriving stock Generic deriving Aeson.ToJSON via (WithoutUnderscore TxWitnesses) @@ -198,8 +224,57 @@ mkTxEvent _parsed_tx = MkTxEvent , _point = "Origin" } - txToText :: TxEvent -> T.Text txToText = T.Encoding.decodeUtf8 . LBS.toStrict - . Aeson.encode \ No newline at end of file + . 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 (T.Encoding.decodeUtf8 bs) + ] + PlutusLedgerApi.V1.List xs -> + Aeson.object + [ "array" .= Aeson.object + [ "items" .= Aeson.Array (datumToJson <$> Vec.fromList xs) + ] + ] \ No newline at end of file diff --git a/test/Utils.hs b/test/Utils.hs index 9763343..02ffb5b 100644 --- a/test/Utils.hs +++ b/test/Utils.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE AllowAmbiguousTypes #-} module Utils where import Prelude @@ -51,6 +52,16 @@ import qualified Data.IORef as IORef import qualified Test.Hspec as Hspec import qualified System.Process as Process +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 From 177accd8db03de54205bc52ff7996c72068eab8f Mon Sep 17 00:00:00 2001 From: Renegatto Date: Thu, 12 Sep 2024 15:37:57 +0300 Subject: [PATCH 12/36] Test that utxoRPC plutus data encoding is accepted by oura --- test/OuraFilters.hs | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/test/OuraFilters.hs b/test/OuraFilters.hs index 8116546..4f158fd 100644 --- a/test/OuraFilters.hs +++ b/test/OuraFilters.hs @@ -17,6 +17,7 @@ import OuraFilters.Auction qualified import qualified OuraFilters.Mock as Mock import Data.Function ((&)) import Control.Lens ((.~), ix) +import qualified PlutusLedgerApi.V1 as V1 exampleMatchingTx :: Mock.TxEvent exampleMatchingTx = @@ -46,7 +47,15 @@ exampleTx = Mock.mkTxEvent $ Mock.arbitraryTx { Mock._address = Mock.MkAddressAsBase64 "cM+tGRS1mdGL/9FNK71pYBnCiZy91qAzJc32gLw=" , Mock._coin = 254564 , Mock._assets = [] - , Mock._datum = Nothing + , Mock._datum = Just + $ Mock.encodePlutusData + $ V1.List + [ V1.Map + [ (V1.I 2, V1.I 33) + ] + , V1.Constr 3 [V1.I 288] + , V1.I 34 + ] , Mock._script = Nothing } From 750da786e2e72a6f438ef64a90c3506870a35aad Mon Sep 17 00:00:00 2001 From: Renegatto Date: Thu, 12 Sep 2024 15:45:25 +0300 Subject: [PATCH 13/36] Format tests via fourmolu --- test/Main.hs | 5 +- test/Oura.hs | 34 +++-- test/Oura/Communication.hs | 1 - test/OuraFilters.hs | 109 ++++++------- test/OuraFilters/Auction.hs | 176 +++++++++++---------- test/OuraFilters/Mock.hs | 296 +++++++++++++++++++----------------- test/Utils.hs | 67 ++++---- 7 files changed, 368 insertions(+), 320 deletions(-) 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..6dcab7f 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,18 +19,19 @@ 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 Control.Concurrent.Async (Async) +import Control.Concurrent.Async qualified as Async import Data.Text.Encoding qualified as Text.Encoding import Oura.Communication qualified as Communication import Oura.Config qualified as Config -import Control.Concurrent.Async (Async) -import Control.Concurrent.Async qualified as Async import System.Directory (removeFile) --- | 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 @@ -87,9 +89,10 @@ 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 + . Text.Encoding.encodeUtf8 pure MkOura {shutDown, receive, send} daemonConfig :: Config.SourcePath -> Config.SinkPath -> T.Text @@ -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..19fafa2 100644 --- a/test/Oura/Communication.hs +++ b/test/Oura/Communication.hs @@ -34,7 +34,6 @@ import Network.Socket.ByteString qualified as Socket.BS import Oura.Config (SinkPath, SourcePath (MkSourcePath), unSinkPath) - data OuraDaemonConnection = MkOuraDaemonConnection { ownSocket :: Socket.Socket , ouraAddress :: Socket.SockAddr diff --git a/test/OuraFilters.hs b/test/OuraFilters.hs index 4f158fd..8a31f59 100644 --- a/test/OuraFilters.hs +++ b/test/OuraFilters.hs @@ -3,21 +3,21 @@ module OuraFilters (ouraFiltersSpec) where -import Prelude -import Oura (Oura (send, receive, shutDown)) -import Oura qualified -import Test.Hspec (Spec, it, focus, shouldBe) +import Control.Lens (ix, (.~)) import Control.Monad ((>=>)) -import qualified Data.Text as T -import Utils qualified -import qualified Data.Aeson.Types as Aeson -import qualified Data.Aeson as Aeson import Data.Aeson ((.:)) -import OuraFilters.Auction qualified -import qualified OuraFilters.Mock as Mock +import Data.Aeson qualified as Aeson +import Data.Aeson.Types qualified as Aeson import Data.Function ((&)) -import Control.Lens ((.~), ix) -import qualified PlutusLedgerApi.V1 as V1 +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 = @@ -27,37 +27,40 @@ exampleMatchingTx = inputAddress = Mock.MkAddressAsBase64 "AZSTMVzZLrXYxDBOZ7fhauNtYdNFAmlGV4EaLI4ze2LP/2QDoGo6y8NPjEYAPGn+eaNijO+pxHJR" exampleTx :: Mock.TxEvent -exampleTx = Mock.mkTxEvent $ Mock.arbitraryTx - & Mock.inputs .~ [ - Mock.MkTxInput - { Mock._tx_hash = Mock.Mk32BitBase16Hash "af6366838cfac9cc56856ffe1d595ad1dd32c9bafb1ca064a08b5c687293110f" - , Mock._output_index = 5 - , Mock._as_output = out - , Mock._redeemer = Nothing - } - ] - & 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 } - +exampleTx = + Mock.mkTxEvent $ + Mock.arbitraryTx + & Mock.inputs + .~ [ Mock.MkTxInput + { Mock._tx_hash = Mock.Mk32BitBase16Hash "af6366838cfac9cc56856ffe1d595ad1dd32c9bafb1ca064a08b5c687293110f" + , Mock._output_index = 5 + , Mock._as_output = out + , Mock._redeemer = Nothing + } + ] + & 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.encodePlutusData - $ V1.List - [ V1.Map - [ (V1.I 2, V1.I 33) - ] - , V1.Constr 3 [V1.I 288] - , V1.I 34 - ] - , Mock._script = Nothing - } + out = + Mock.MkTxOutput + { Mock._address = Mock.MkAddressAsBase64 "cM+tGRS1mdGL/9FNK71pYBnCiZy91qAzJc32gLw=" + , Mock._coin = 254564 + , Mock._assets = [] + , Mock._datum = + Just $ + Mock.encodePlutusData $ + V1.List + [ V1.Map + [ (V1.I 2, V1.I 33) + ] + , V1.Constr 3 [V1.I 288] + , V1.I 34 + ] + , Mock._script = Nothing + } ouraFiltersSpec :: Spec ouraFiltersSpec = Utils.killProcessesOnError do @@ -69,20 +72,22 @@ ouraFiltersSpec = Utils.killProcessesOnError do oura.send tx -- _ <- oura.receive oura.send matchingTx - Right outTxHash - <- extractOutputTxHash <$> oura.receive - Right inputTxHash - <- pure $ extractInputTxHash matchingTx + Right outTxHash <- + extractOutputTxHash <$> oura.receive + Right inputTxHash <- + pure $ extractInputTxHash matchingTx outTxHash `shouldBe` inputTxHash oura.shutDown OuraFilters.Auction.spec extractInputTxHash :: T.Text -> Either String T.Text -extractInputTxHash = Aeson.eitherDecodeStrictText >=> Aeson.parseEither \json -> do - parsedTx <- json .: "parsed_tx" - parsedTx .: "hash" +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 +extractOutputTxHash = + Aeson.eitherDecodeStrictText >=> Aeson.parseEither \json -> do + parsedTx <- json .: "record" + parsedTx .: "hash" diff --git a/test/OuraFilters/Auction.hs b/test/OuraFilters/Auction.hs index 8508331..34ca639 100644 --- a/test/OuraFilters/Auction.hs +++ b/test/OuraFilters/Auction.hs @@ -1,41 +1,45 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE PackageImports #-} + module OuraFilters.Auction (spec) where -import Prelude -import Utils (SpotGarbage) -import System.Process (ProcessHandle) -import Test.Hspec (describe, it, focus, HasCallStack) -import Test.Hspec.Core.Spec (SpecM) -import qualified OuraFilters.Mock as Mock -import Data.Function ((&)) -import Cardano.CEM.Examples.Auction (SimpleAuctionState(NotStarted)) -import qualified Cardano.CEM.Examples.Auction as Auction -import qualified PlutusLedgerApi.V1 + +import Cardano.Api.Ledger qualified +import Cardano.Api.SerialiseRaw qualified as SerialiseRaw +import Cardano.CEM.Examples.Auction (SimpleAuctionState (NotStarted)) +import Cardano.CEM.Examples.Auction qualified as Auction +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 Control.Arrow ((>>>)) -import qualified PlutusTx.AssocMap as AssocMap +import Data.Base64.Types qualified as Base64 +import Data.ByteString.Base64 qualified as BS.Base64 +import Data.Function ((&)) import Data.Functor ((<&>)) -import qualified Data.Text.Encoding as T.Encoding -import "cardano-api" Cardano.Api.Address qualified as Address -import qualified Cardano.Api.SerialiseRaw as SerialiseRaw -import qualified Cardano.Ledger.BaseTypes as Ledger -import qualified Cardano.Ledger.Credential as Cred -import qualified Cardano.Ledger.Keys as Ledger.Keys -import qualified Cardano.Crypto.Hash as Cardano.Hash import Data.Maybe (fromJust) -import qualified Cardano.Api.Ledger -import qualified Cardano.Ledger.Hashes -import qualified Data.Base64.Types as Base64 -import qualified Data.ByteString.Base64 as BS.Base64 +import Data.Text.Encoding qualified as T.Encoding +import OuraFilters.Mock qualified as Mock +import PlutusLedgerApi.V1 qualified +import PlutusTx.AssocMap qualified as AssocMap +import System.Process (ProcessHandle) +import Test.Hspec (HasCallStack, describe, focus, it) +import Test.Hspec.Core.Spec (SpecM) +import Utils (SpotGarbage) +import "cardano-api" Cardano.Api.Address qualified as Address +import Prelude spec :: SpecM (SpotGarbage IO ProcessHandle) () -spec = +spec = describe "Auction example" do - focus $ it "Recognizes 'Create' transition" \spotGarbage -> do + it "Recognizes 'Create' transition" \spotGarbage -> do let - addr = PlutusLedgerApi.V1.Address - (PlutusLedgerApi.V1.PubKeyCredential - (PlutusLedgerApi.V1.PubKeyHash "e628bfd68c07a7a38fcd7d8df650812a9dfdbee54b1ed4c25c87ffbf")) + addr = + PlutusLedgerApi.V1.Address + ( PlutusLedgerApi.V1.PubKeyCredential + (PlutusLedgerApi.V1.PubKeyHash "e628bfd68c07a7a38fcd7d8df650812a9dfdbee54b1ed4c25c87ffbf") + ) Nothing print $ PlutusLedgerApi.V1.toBuiltinData addr fail @IO @() "Not implemented" @@ -48,31 +52,32 @@ spec = it "Recognizes 'Buyout' transition" \spotGarbage -> do fail @IO @() "Not implemented" -plutusAaddressToOuraAddress :: HasCallStack => PlutusLedgerApi.V1.Address -> Mock.Address -plutusAaddressToOuraAddress ( PlutusLedgerApi.V1.Address payment stake) = - Mock.MkAddressAsBase64 - $ Base64.extractBase64 - $ BS.Base64.encodeBase64 - $ SerialiseRaw.serialiseToRawBytes - $ Address.ShelleyAddress - Ledger.Mainnet - (fromJust paymentCredential) - (fromJust stakeCredential) +plutusAaddressToOuraAddress :: (HasCallStack) => PlutusLedgerApi.V1.Address -> Mock.Address +plutusAaddressToOuraAddress (PlutusLedgerApi.V1.Address payment stake) = + Mock.MkAddressAsBase64 $ + Base64.extractBase64 $ + BS.Base64.encodeBase64 $ + SerialiseRaw.serialiseToRawBytes $ + Address.ShelleyAddress + Ledger.Mainnet + (fromJust paymentCredential) + (fromJust stakeCredential) where - credentialToCardano - (PlutusLedgerApi.V1.PubKeyCredential - (PlutusLedgerApi.V1.PubKeyHash pkh)) = - Cred.KeyHashObj - . Ledger.Keys.KeyHash - <$> Cardano.Hash.hashFromBytes (PlutusLedgerApi.V1.fromBuiltin pkh) + ( 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) + ( 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 @@ -80,48 +85,53 @@ plutusAaddressToOuraAddress ( PlutusLedgerApi.V1.Address payment stake) = Just ref -> case ref of PlutusLedgerApi.V1.StakingHash cred -> Cardano.Api.Ledger.StakeRefBase - <$> credentialToCardano cred + <$> credentialToCardano cred PlutusLedgerApi.V1.StakingPtr {} -> error "Staking pointers are not supported" createTxMock :: Auction.SimpleAuctionParams -> Mock.Tx -createTxMock params = Mock.arbitraryTx - & undefined +createTxMock params = + Mock.arbitraryTx + & undefined where - input = Mock.MkTxInput - { Mock._as_output = Mock.MkTxOutput - { Mock._address = - plutusAaddressToOuraAddress - $ PlutusLedgerApi.V1.Address - (PlutusLedgerApi.V1.PubKeyCredential params.seller) - Nothing - , Mock._datum = Nothing -- any datum - , Mock._coin = 2 - , Mock._script = Nothing - , Mock._assets = valueToMultiAsset params.lot + input = + Mock.MkTxInput + { Mock._as_output = + Mock.MkTxOutput + { Mock._address = + plutusAaddressToOuraAddress $ + PlutusLedgerApi.V1.Address + (PlutusLedgerApi.V1.PubKeyCredential params.seller) + Nothing + , Mock._datum = Nothing -- any datum + , Mock._coin = 2 + , Mock._script = Nothing + , Mock._assets = valueToMultiAsset params.lot + } + , Mock._tx_hash = Mock.Mk32BitBase16Hash "af6366838cfac9cc56856ffe1d595ad1dd32c9bafb1ca064a08b5c687293110f" + , Mock._output_index = 0 + , Mock._redeemer = undefined } - , Mock._tx_hash = Mock.Mk32BitBase16Hash "af6366838cfac9cc56856ffe1d595ad1dd32c9bafb1ca064a08b5c687293110f" - , Mock._output_index = 0 - , Mock._redeemer = undefined - } valueToMultiAsset :: PlutusLedgerApi.V1.Value -> [Mock.Multiasset] valueToMultiAsset = - PlutusLedgerApi.V1.getValue >>> AssocMap.toList >>> fmap \(cs,tokens) -> + PlutusLedgerApi.V1.getValue >>> AssocMap.toList >>> fmap \(cs, tokens) -> Mock.MkMultiasset - { Mock._policy_id = - T.Encoding.decodeUtf8 - $ PlutusLedgerApi.V1.fromBuiltin - $ PlutusLedgerApi.V1.unCurrencySymbol cs - , Mock.assets = AssocMap.toList tokens <&> \(tn,amt) -> - Mock.MkAsset - { Mock._name = T.Encoding.decodeUtf8 - $ PlutusLedgerApi.V1.fromBuiltin - $ PlutusLedgerApi.V1.unTokenName tn - , Mock._output_coin = amt -- positive - , Mock._mint_coin = 1 - } - , Mock.redeemer = Nothing - } + { Mock._policy_id = + T.Encoding.decodeUtf8 $ + PlutusLedgerApi.V1.fromBuiltin $ + PlutusLedgerApi.V1.unCurrencySymbol cs + , Mock.assets = + AssocMap.toList tokens <&> \(tn, amt) -> + Mock.MkAsset + { Mock._name = + T.Encoding.decodeUtf8 $ + PlutusLedgerApi.V1.fromBuiltin $ + PlutusLedgerApi.V1.unTokenName tn + , Mock._output_coin = amt -- positive + , Mock._mint_coin = 1 + } + , Mock.redeemer = Nothing + } inputState = Nothing - outputState = Just NotStarted \ No newline at end of file + outputState = Just NotStarted diff --git a/test/OuraFilters/Mock.hs b/test/OuraFilters/Mock.hs index be05ee0..3dad6a1 100644 --- a/test/OuraFilters/Mock.hs +++ b/test/OuraFilters/Mock.hs @@ -1,49 +1,54 @@ -{-# OPTIONS_GHC -Wno-partial-type-signatures #-} -{-# LANGUAGE DuplicateRecordFields, NoFieldSelectors #-} -{-# LANGUAGE BlockArguments #-} {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} + module OuraFilters.Mock where -import Prelude + import Control.Lens.TH (makeLenses, makeLensesFor) -import Data.ByteString.Lazy qualified as LBS +import Data.Aeson (KeyValue ((.=))) import Data.Aeson qualified as Aeson +import Data.Base64.Types qualified as Base64.Types +import Data.ByteString qualified as BS +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.Text.Encoding qualified as T.Encoding +import Data.Vector qualified as Vec import GHC.Generics (Generic (Rep)) import PlutusLedgerApi.V1 qualified -import Data.Aeson (KeyValue((.=))) -import Data.Vector qualified as Vec -import Data.Functor ((<&>)) -import Data.ByteString qualified as BS -import Data.ByteString.Base64 qualified as Base64 -import Data.Base64.Types qualified as Base64.Types import Utils (digits) +import Prelude newtype WithoutUnderscore a = MkWithoutUnderscore a - deriving newtype Generic + deriving newtype (Generic) withoutLeadingUnderscore :: Aeson.Options withoutLeadingUnderscore = Aeson.defaultOptions { Aeson.fieldLabelModifier = \case - '_':fieldName -> fieldName - fieldName -> fieldName + '_' : fieldName -> fieldName + fieldName -> fieldName } instance - (Generic a + ( Generic a , Aeson.GToJSON' Aeson.Value Aeson.Zero (GHC.Generics.Rep a) - ) => Aeson.ToJSON (WithoutUnderscore a) where + ) => + 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 T.Text - deriving newtype Aeson.ToJSON - deriving newtype Aeson.FromJSON + deriving newtype (Aeson.ToJSON) + deriving newtype (Aeson.FromJSON) makeLenses ''Address newtype Hash32 = Mk32BitBase16Hash T.Text - deriving newtype Aeson.ToJSON - deriving newtype Aeson.FromJSON + deriving newtype (Aeson.ToJSON) + deriving newtype (Aeson.FromJSON) makeLenses ''Hash32 data Asset = MkAsset @@ -51,9 +56,9 @@ data Asset = MkAsset , _output_coin :: Integer -- positive , _mint_coin :: Integer } - deriving stock Generic - deriving Aeson.ToJSON via (WithoutUnderscore Asset) - deriving Aeson.FromJSON via (WithoutUnderscore Asset) + deriving stock (Generic) + deriving (Aeson.ToJSON) via (WithoutUnderscore Asset) + deriving (Aeson.FromJSON) via (WithoutUnderscore Asset) makeLenses ''Asset data Multiasset = MkMultiasset @@ -61,18 +66,18 @@ data Multiasset = MkMultiasset , assets :: [Asset] , redeemer :: Maybe Aeson.Value } - deriving stock Generic - deriving Aeson.ToJSON via (WithoutUnderscore Multiasset) - deriving Aeson.FromJSON via (WithoutUnderscore Multiasset) + deriving stock (Generic) + deriving (Aeson.ToJSON) via (WithoutUnderscore Multiasset) + deriving (Aeson.FromJSON) via (WithoutUnderscore Multiasset) makeLenses ''Multiasset makeLensesFor - [ ("assets","multiassetAssets") - , ("redeemer","multiassetRedeemer") + [ ("assets", "multiassetAssets") + , ("redeemer", "multiassetRedeemer") ] ''Multiasset -newtype PlutusData = MkPlutusData { _plutusData :: Aeson.Value } - deriving newtype Generic +newtype PlutusData = MkPlutusData {_plutusData :: Aeson.Value} + deriving newtype (Generic) deriving newtype (Aeson.FromJSON, Aeson.ToJSON) makeLenses ''PlutusData @@ -81,11 +86,11 @@ data Datum = MkDatum , _payload :: Maybe PlutusData , _original_cbor :: T.Text } - deriving stock Generic - deriving Aeson.ToJSON via (WithoutUnderscore Datum) - deriving Aeson.FromJSON via (WithoutUnderscore Datum) + deriving stock (Generic) + deriving (Aeson.ToJSON) via (WithoutUnderscore Datum) + deriving (Aeson.FromJSON) via (WithoutUnderscore Datum) makeLenses ''Datum -makeLensesFor [("hash","datum_hash")] ''Datum +makeLensesFor [("hash", "datum_hash")] ''Datum data TxOutput = MkTxOutput { _address :: Address @@ -94,9 +99,9 @@ data TxOutput = MkTxOutput , _datum :: Maybe PlutusData , _script :: Maybe Aeson.Value } - deriving stock Generic - deriving Aeson.ToJSON via (WithoutUnderscore TxOutput) - deriving Aeson.FromJSON via (WithoutUnderscore TxOutput) + deriving stock (Generic) + deriving (Aeson.ToJSON) via (WithoutUnderscore TxOutput) + deriving (Aeson.FromJSON) via (WithoutUnderscore TxOutput) makeLenses ''TxOutput data TxInput = MkTxInput @@ -105,9 +110,9 @@ data TxInput = MkTxInput , _as_output :: TxOutput , _redeemer :: Maybe Datum } - deriving stock Generic - deriving Aeson.ToJSON via (WithoutUnderscore TxInput) - deriving Aeson.FromJSON via (WithoutUnderscore TxInput) + deriving stock (Generic) + deriving (Aeson.ToJSON) via (WithoutUnderscore TxInput) + deriving (Aeson.FromJSON) via (WithoutUnderscore TxInput) makeLenses ''TxInput data TxWitnesses = MkTxWitnesses @@ -115,9 +120,10 @@ data TxWitnesses = MkTxWitnesses , _script :: [Aeson.Value] , _plutus_datums :: [Datum] } - deriving stock Generic - deriving Aeson.ToJSON via (WithoutUnderscore TxWitnesses) - deriving Aeson.FromJSON via (WithoutUnderscore TxWitnesses) + deriving stock (Generic) + deriving (Aeson.ToJSON) via (WithoutUnderscore TxWitnesses) + deriving (Aeson.FromJSON) via (WithoutUnderscore TxWitnesses) + -- makeLenses ''TxWitnesses data TxCollateral = MkTxCollateral @@ -125,66 +131,71 @@ data TxCollateral = MkTxCollateral , _collateral_return :: TxOutput , _total_collateral :: Integer } - deriving stock Generic - deriving Aeson.ToJSON via (WithoutUnderscore TxCollateral) - deriving Aeson.FromJSON via (WithoutUnderscore TxCollateral) + 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) + 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) + 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 +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 = Mk32BitBase16Hash "af6366838cfac9cc56856ffe1d595ad1dd32c9bafb1ca064a08b5c687293110f" } - , _fee = 0 - , _validity = MkTxValidity - { _start = 0 - , _ttl = 0 - } - , _successful = True - , _auxiliary = MkTxAuxiliary - { _metadata = [] - , _scripts = [] - } - , _hash = Mk32BitBase16Hash "af6366838cfac9cc56856ffe1d595ad1dd32c9bafb1ca064a08b5c687293110f" - } - -- Source: https://docs.rs/utxorpc-spec/latest/utxorpc_spec/utxorpc/v1alpha/cardano/struct.Tx.html data Tx = MkTx @@ -202,32 +213,33 @@ data Tx = MkTx , _auxiliary :: TxAuxiliary , _hash :: Hash32 } - deriving stock Generic - deriving Aeson.ToJSON via (WithoutUnderscore Tx) - deriving Aeson.FromJSON via (WithoutUnderscore Tx) + deriving stock (Generic) + deriving (Aeson.ToJSON) via (WithoutUnderscore Tx) + deriving (Aeson.FromJSON) via (WithoutUnderscore Tx) makeLenses ''Tx -makeLensesFor [("collateral","txCollateral")] ''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) + 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" - } +mkTxEvent _parsed_tx = + MkTxEvent + { _parsed_tx + , _point = "Origin" + } txToText :: TxEvent -> T.Text -txToText = T.Encoding.decodeUtf8 - . LBS.toStrict - . Aeson.encode +txToText = + T.Encoding.decodeUtf8 + . LBS.toStrict + . Aeson.encode encodePlutusData :: PlutusLedgerApi.V1.Data -> PlutusData encodePlutusData = MkPlutusData . datumToJson @@ -238,43 +250,53 @@ 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) - ] + [ "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.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.B bs -> + Aeson.object + [ "bounded_bytes" + .= Aeson.String (T.Encoding.decodeUtf8 bs) ] - ] - 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 (T.Encoding.decodeUtf8 bs) - ] PlutusLedgerApi.V1.List xs -> Aeson.object - [ "array" .= Aeson.object - [ "items" .= Aeson.Array (datumToJson <$> Vec.fromList xs) + [ "array" + .= Aeson.object + [ "items" .= Aeson.Array (datumToJson <$> Vec.fromList xs) + ] ] - ] \ No newline at end of file diff --git a/test/Utils.hs b/test/Utils.hs index 02ffb5b..7be07fd 100644 --- a/test/Utils.hs +++ b/test/Utils.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE BlockArguments #-} {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BlockArguments #-} + module Utils where import Prelude @@ -44,23 +45,26 @@ import Cardano.Extras import Data.Spine (HasSpine (..)) import Control.Exception (bracket) +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 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 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 - [] -> [] +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 @@ -173,7 +177,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 () @@ -181,18 +185,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 ()) -> @@ -200,17 +207,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 From b3c92d37be90a9093f5f6f45b3b7edb443dabbab Mon Sep 17 00:00:00 2001 From: Renegatto Date: Thu, 12 Sep 2024 15:50:12 +0300 Subject: [PATCH 14/36] Debug utxoRPC PlutusData.Bytes encoding --- test/OuraFilters.hs | 1 + test/OuraFilters/Mock.hs | 5 ++++- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/test/OuraFilters.hs b/test/OuraFilters.hs index 8a31f59..8f4d836 100644 --- a/test/OuraFilters.hs +++ b/test/OuraFilters.hs @@ -58,6 +58,7 @@ exampleTx = ] , V1.Constr 3 [V1.I 288] , V1.I 34 + , V1.B "aboba" ] , Mock._script = Nothing } diff --git a/test/OuraFilters/Mock.hs b/test/OuraFilters/Mock.hs index 3dad6a1..44d80c0 100644 --- a/test/OuraFilters/Mock.hs +++ b/test/OuraFilters/Mock.hs @@ -291,7 +291,10 @@ datumToJson = PlutusLedgerApi.V1.B bs -> Aeson.object [ "bounded_bytes" - .= Aeson.String (T.Encoding.decodeUtf8 bs) + .= Aeson.String + ( Base64.Types.extractBase64 $ + Base64.encodeBase64 bs + ) ] PlutusLedgerApi.V1.List xs -> Aeson.object From 07d53bbc6b32e3ee694bf7ffe74bbb79e71d124e Mon Sep 17 00:00:00 2001 From: Renegatto Date: Thu, 12 Sep 2024 21:45:38 +0300 Subject: [PATCH 15/36] Distinct between 28B and 32B blake2b hashes --- cem-script.cabal | 3 + test/OuraFilters.hs | 8 ++- test/OuraFilters/Auction.hs | 107 +++++++++++++++++++++++++++++------- test/OuraFilters/Mock.hs | 52 +++++++++++++----- test/Utils.hs | 5 ++ 5 files changed, 139 insertions(+), 36 deletions(-) diff --git a/cem-script.cabal b/cem-script.cabal index 6dce400..7a6adfa 100644 --- a/cem-script.cabal +++ b/cem-script.cabal @@ -193,6 +193,9 @@ test-suite cem-sdk-test , cardano-api , cardano-ledger-core , vector + , safe + , base16 + , base32 hs-source-dirs: test/ other-modules: diff --git a/test/OuraFilters.hs b/test/OuraFilters.hs index 8f4d836..760dc47 100644 --- a/test/OuraFilters.hs +++ b/test/OuraFilters.hs @@ -32,10 +32,14 @@ exampleTx = Mock.arbitraryTx & Mock.inputs .~ [ Mock.MkTxInput - { Mock._tx_hash = Mock.Mk32BitBase16Hash "af6366838cfac9cc56856ffe1d595ad1dd32c9bafb1ca064a08b5c687293110f" + { Mock._tx_hash = Mock.MkBlake2b255Hex "af6366838cfac9cc56856ffe1d595ad1dd32c9bafb1ca064a08b5c687293110f" , Mock._output_index = 5 , Mock._as_output = out - , Mock._redeemer = Nothing + , Mock._redeemer = Just + $ Mock.MkRedeemer + { _purpose = Mock.PURPOSE_UNSPECIFIED + , datum = Mock.encodePlutusData (V1.I 212) + } } ] & Mock.outputs .~ [out] diff --git a/test/OuraFilters/Auction.hs b/test/OuraFilters/Auction.hs index 34ca639..60aafc3 100644 --- a/test/OuraFilters/Auction.hs +++ b/test/OuraFilters/Auction.hs @@ -18,31 +18,74 @@ import Data.Base64.Types qualified as Base64 import Data.ByteString.Base64 qualified as BS.Base64 import Data.Function ((&)) import Data.Functor ((<&>)) -import Data.Maybe (fromJust) +import Data.Maybe (fromJust, fromMaybe) import Data.Text.Encoding qualified as T.Encoding import OuraFilters.Mock qualified as Mock import PlutusLedgerApi.V1 qualified import PlutusTx.AssocMap qualified as AssocMap import System.Process (ProcessHandle) -import Test.Hspec (HasCallStack, describe, focus, it) +import Test.Hspec (HasCallStack, describe, focus, it, shouldBe) import Test.Hspec.Core.Spec (SpecM) -import Utils (SpotGarbage) +import Utils (SpotGarbage, resultToEither) import "cardano-api" Cardano.Api.Address qualified as Address import Prelude +import Cardano.CEM (CEMScriptDatum) +import Control.Lens ((%~), (.~), (^.)) +import qualified Oura +import qualified Data.Aeson as Aeson +import qualified PlutusLedgerApi.V1.Value as V1.Value +import qualified Data.Text as T +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base16 as Base16 +import qualified Data.ByteString.Base32 as Base32 +import qualified Data.Base16.Types as Base16.Types +import qualified Data.ByteString.Base64 as Base64 +import qualified Data.Base64.Types as Base64.Types +import Data.Coerce (coerce) spec :: SpecM (SpotGarbage IO ProcessHandle) () spec = describe "Auction example" do - it "Recognizes 'Create' transition" \spotGarbage -> do - let - addr = + focus $ it "Recognizes 'Create' transition" \spotGarbage -> do + Oura.withOura (Oura.MkWorkDir "./tmp") spotGarbage \oura -> do + let + params = Auction.MkAuctionParams + { seller = "e01bb07f0cd514c0b8b73572e8c5e7492449c5f68702fdac758225f4" -- "e01bb07f0cd514c0b8b73572e8c5e7492449c5f68702fdac758225f4" + , lot = V1.Value.assetClassValue + (V1.Value.assetClass + "94906060606060606060606060606060606060606060606969669696" + "fea6" + ) + 4 + } + flip shouldBe 28 + $ BS.length + -- $ Base16.decodeBase16 + -- $ Base16.Types.assertBase16 + $ PlutusLedgerApi.V1.fromBuiltin + $ PlutusLedgerApi.V1.getPubKeyHash params.seller + let + rightTxHash = Mock.MkBlake2b255Hex + "2266778888888888888888888888888888888888888888888888444444444444" + tx = Mock.txToText + $ Mock.mkTxEvent + $ Mock.hash .~ rightTxHash + $ createTxMock params + unmatchingTx = Mock.txToText $ Mock.mkTxEvent Mock.arbitraryTx + putStrLn "evaluating" + print $ plutusAaddressToOuraAddress $ PlutusLedgerApi.V1.Address - ( PlutusLedgerApi.V1.PubKeyCredential - (PlutusLedgerApi.V1.PubKeyHash "e628bfd68c07a7a38fcd7d8df650812a9dfdbee54b1ed4c25c87ffbf") - ) + (PlutusLedgerApi.V1.PubKeyCredential params.seller) Nothing - print $ PlutusLedgerApi.V1.toBuiltinData addr - fail @IO @() "Not implemented" + putStrLn "good" + oura.send unmatchingTx + putStrLn "Sent1" + oura.send tx + putStrLn "Sent2" + Right txEvent <- Aeson.eitherDecodeStrictText @Mock.TxEvent + <$> oura.receive + (txEvent ^. Mock.parsed_tx . Mock.hash) `shouldBe` rightTxHash + oura.shutDown it "Recognizes 'Start' transition" \spotGarbage -> do fail @IO @() "Not implemented" it "Recognizes 'MakeBid' transition" \spotGarbage -> do @@ -52,7 +95,7 @@ spec = it "Recognizes 'Buyout' transition" \spotGarbage -> do fail @IO @() "Not implemented" -plutusAaddressToOuraAddress :: (HasCallStack) => PlutusLedgerApi.V1.Address -> Mock.Address +plutusAaddressToOuraAddress :: HasCallStack => PlutusLedgerApi.V1.Address -> Mock.Address plutusAaddressToOuraAddress (PlutusLedgerApi.V1.Address payment stake) = Mock.MkAddressAsBase64 $ Base64.extractBase64 $ @@ -60,8 +103,12 @@ plutusAaddressToOuraAddress (PlutusLedgerApi.V1.Address payment stake) = SerialiseRaw.serialiseToRawBytes $ Address.ShelleyAddress Ledger.Mainnet - (fromJust paymentCredential) - (fromJust stakeCredential) + (fromMaybe + (error "plutusAaddressToOuraAddress:can't decode payment credential") + paymentCredential) + (fromMaybe + (error "plutusAaddressToOuraAddress:can't decode stake credential") + stakeCredential) where credentialToCardano ( PlutusLedgerApi.V1.PubKeyCredential @@ -69,7 +116,8 @@ plutusAaddressToOuraAddress (PlutusLedgerApi.V1.Address payment stake) = ) = Cred.KeyHashObj . Ledger.Keys.KeyHash - <$> Cardano.Hash.hashFromBytes (PlutusLedgerApi.V1.fromBuiltin pkh) + <$> Cardano.Hash.hashFromBytes + (PlutusLedgerApi.V1.fromBuiltin pkh) credentialToCardano ( PlutusLedgerApi.V1.ScriptCredential (PlutusLedgerApi.V1.ScriptHash scriptHash) @@ -92,7 +140,8 @@ plutusAaddressToOuraAddress (PlutusLedgerApi.V1.Address payment stake) = createTxMock :: Auction.SimpleAuctionParams -> Mock.Tx createTxMock params = Mock.arbitraryTx - & undefined + & Mock.inputs %~ (:) input + & Mock.outputs %~ (:) output where input = Mock.MkTxInput @@ -108,10 +157,28 @@ createTxMock params = , Mock._script = Nothing , Mock._assets = valueToMultiAsset params.lot } - , Mock._tx_hash = Mock.Mk32BitBase16Hash "af6366838cfac9cc56856ffe1d595ad1dd32c9bafb1ca064a08b5c687293110f" + , Mock._tx_hash = Mock.MkBlake2b255Hex "af6366838cfac9cc56856ffe1d595ad1dd32c9bafb1ca064a08b5c687293110f" , Mock._output_index = 0 - , Mock._redeemer = undefined + , Mock._redeemer = Just + $ Mock.MkRedeemer + { _purpose = Mock.PURPOSE_SPEND + , datum = Mock.encodePlutusData + $ PlutusLedgerApi.V1.toData Auction.Create + } } + output = Mock.MkTxOutput + { Mock._address = + plutusAaddressToOuraAddress $ + PlutusLedgerApi.V1.Address + (PlutusLedgerApi.V1.PubKeyCredential params.seller) + Nothing + , Mock._datum = Just + $ Mock.encodePlutusData + $ PlutusLedgerApi.V1.toData outputState + , Mock._coin = 2 + , Mock._script = Nothing + , Mock._assets = valueToMultiAsset params.lot + } valueToMultiAsset :: PlutusLedgerApi.V1.Value -> [Mock.Multiasset] valueToMultiAsset = PlutusLedgerApi.V1.getValue >>> AssocMap.toList >>> fmap \(cs, tokens) -> @@ -133,5 +200,5 @@ createTxMock params = , Mock.redeemer = Nothing } - inputState = Nothing - outputState = Just NotStarted + outputState :: CEMScriptDatum Auction.SimpleAuction + outputState = (Auction.NoControl, params, Auction.NotStarted) diff --git a/test/OuraFilters/Mock.hs b/test/OuraFilters/Mock.hs index 44d80c0..3b8cf19 100644 --- a/test/OuraFilters/Mock.hs +++ b/test/OuraFilters/Mock.hs @@ -21,6 +21,8 @@ import GHC.Generics (Generic (Rep)) import PlutusLedgerApi.V1 qualified import Utils (digits) import Prelude +import qualified Safe +import Control.Monad ((<=<)) newtype WithoutUnderscore a = MkWithoutUnderscore a deriving newtype (Generic) @@ -42,15 +44,23 @@ instance instance (Generic a, Aeson.GFromJSON Aeson.Zero (Rep a)) => Aeson.FromJSON (WithoutUnderscore a) where parseJSON = Aeson.genericParseJSON withoutLeadingUnderscore newtype Address = MkAddressAsBase64 T.Text - deriving newtype (Aeson.ToJSON) - deriving newtype (Aeson.FromJSON) + deriving newtype (Show, Eq, Ord, Aeson.ToJSON, Aeson.FromJSON) makeLenses ''Address -newtype Hash32 = Mk32BitBase16Hash T.Text +-- 32B long +newtype Hash32 = MkBlake2b255Hex T.Text + deriving newtype (Show, Eq, Ord) deriving newtype (Aeson.ToJSON) deriving newtype (Aeson.FromJSON) makeLenses ''Hash32 +-- 28B long +newtype Hash28 = MkBlake2b244Hex 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 @@ -81,16 +91,30 @@ newtype PlutusData = MkPlutusData {_plutusData :: Aeson.Value} deriving newtype (Aeson.FromJSON, Aeson.ToJSON) makeLenses ''PlutusData -data Datum = MkDatum - { hash :: Hash32 - , _payload :: Maybe PlutusData - , _original_cbor :: T.Text +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 Redeemer = MkRedeemer + { _purpose :: Purpose + , datum :: PlutusData } deriving stock (Generic) - deriving (Aeson.ToJSON) via (WithoutUnderscore Datum) - deriving (Aeson.FromJSON) via (WithoutUnderscore Datum) -makeLenses ''Datum -makeLensesFor [("hash", "datum_hash")] ''Datum + deriving (Aeson.ToJSON) via (WithoutUnderscore Redeemer) + deriving (Aeson.FromJSON) via (WithoutUnderscore Redeemer) +makeLenses ''Redeemer data TxOutput = MkTxOutput { _address :: Address @@ -108,7 +132,7 @@ data TxInput = MkTxInput { _tx_hash :: Hash32 , _output_index :: Integer , _as_output :: TxOutput - , _redeemer :: Maybe Datum + , _redeemer :: Maybe Redeemer } deriving stock (Generic) deriving (Aeson.ToJSON) via (WithoutUnderscore TxInput) @@ -118,7 +142,7 @@ makeLenses ''TxInput data TxWitnesses = MkTxWitnesses { _vkeywitness :: [Aeson.Value] , _script :: [Aeson.Value] - , _plutus_datums :: [Datum] + , _plutus_datums :: [Aeson.Value] } deriving stock (Generic) deriving (Aeson.ToJSON) via (WithoutUnderscore TxWitnesses) @@ -194,7 +218,7 @@ arbitraryTx = { _metadata = [] , _scripts = [] } - , _hash = Mk32BitBase16Hash "af6366838cfac9cc56856ffe1d595ad1dd32c9bafb1ca064a08b5c687293110f" + , _hash = MkBlake2b255Hex "af6366838cfac9cc56856ffe1d595ad1dd32c9bafb1ca064a08b5c687293110f" } -- Source: https://docs.rs/utxorpc-spec/latest/utxorpc_spec/utxorpc/v1alpha/cardano/struct.Tx.html diff --git a/test/Utils.hs b/test/Utils.hs index 7be07fd..3587907 100644 --- a/test/Utils.hs +++ b/test/Utils.hs @@ -52,6 +52,11 @@ import System.IO (hClose, openTempFile) import System.Process qualified as Process import Test.Hspec qualified as Hspec import TestNFT +import qualified Data.Aeson.Types as Aeson + +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 From 9b3486ccd45a38a1c465c3a1823d983f9d7c871f Mon Sep 17 00:00:00 2001 From: Renegatto Date: Thu, 12 Sep 2024 21:50:13 +0300 Subject: [PATCH 16/36] Format --- test/OuraFilters.hs | 11 +-- test/OuraFilters/Auction.hs | 145 ++++++++++++++++++++---------------- test/OuraFilters/Mock.hs | 7 +- test/Utils.hs | 2 +- 4 files changed, 90 insertions(+), 75 deletions(-) diff --git a/test/OuraFilters.hs b/test/OuraFilters.hs index 760dc47..0e997de 100644 --- a/test/OuraFilters.hs +++ b/test/OuraFilters.hs @@ -35,11 +35,12 @@ exampleTx = { Mock._tx_hash = Mock.MkBlake2b255Hex "af6366838cfac9cc56856ffe1d595ad1dd32c9bafb1ca064a08b5c687293110f" , Mock._output_index = 5 , Mock._as_output = out - , Mock._redeemer = Just - $ Mock.MkRedeemer - { _purpose = Mock.PURPOSE_UNSPECIFIED - , datum = Mock.encodePlutusData (V1.I 212) - } + , Mock._redeemer = + Just $ + Mock.MkRedeemer + { _purpose = Mock.PURPOSE_UNSPECIFIED + , datum = Mock.encodePlutusData (V1.I 212) + } } ] & Mock.outputs .~ [out] diff --git a/test/OuraFilters/Auction.hs b/test/OuraFilters/Auction.hs index 60aafc3..22f1e3a 100644 --- a/test/OuraFilters/Auction.hs +++ b/test/OuraFilters/Auction.hs @@ -6,6 +6,7 @@ module OuraFilters.Auction (spec) where import Cardano.Api.Ledger qualified import Cardano.Api.SerialiseRaw qualified as SerialiseRaw +import Cardano.CEM (CEMScriptDatum) import Cardano.CEM.Examples.Auction (SimpleAuctionState (NotStarted)) import Cardano.CEM.Examples.Auction qualified as Auction import Cardano.Crypto.Hash qualified as Cardano.Hash @@ -14,14 +15,26 @@ import Cardano.Ledger.Credential qualified as Cred import Cardano.Ledger.Hashes qualified import Cardano.Ledger.Keys qualified as Ledger.Keys import Control.Arrow ((>>>)) +import Control.Lens ((%~), (.~), (^.)) +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.Base32 qualified as Base32 import Data.ByteString.Base64 qualified as BS.Base64 +import Data.ByteString.Base64 qualified as Base64 +import Data.Coerce (coerce) import Data.Function ((&)) import Data.Functor ((<&>)) import Data.Maybe (fromJust, fromMaybe) +import Data.Text qualified as T import Data.Text.Encoding qualified as T.Encoding +import Oura qualified import OuraFilters.Mock qualified as Mock import PlutusLedgerApi.V1 qualified +import PlutusLedgerApi.V1.Value qualified as V1.Value import PlutusTx.AssocMap qualified as AssocMap import System.Process (ProcessHandle) import Test.Hspec (HasCallStack, describe, focus, it, shouldBe) @@ -29,19 +42,6 @@ import Test.Hspec.Core.Spec (SpecM) import Utils (SpotGarbage, resultToEither) import "cardano-api" Cardano.Api.Address qualified as Address import Prelude -import Cardano.CEM (CEMScriptDatum) -import Control.Lens ((%~), (.~), (^.)) -import qualified Oura -import qualified Data.Aeson as Aeson -import qualified PlutusLedgerApi.V1.Value as V1.Value -import qualified Data.Text as T -import qualified Data.ByteString as BS -import qualified Data.ByteString.Base16 as Base16 -import qualified Data.ByteString.Base32 as Base32 -import qualified Data.Base16.Types as Base16.Types -import qualified Data.ByteString.Base64 as Base64 -import qualified Data.Base64.Types as Base64.Types -import Data.Coerce (coerce) spec :: SpecM (SpotGarbage IO ProcessHandle) () spec = @@ -49,41 +49,48 @@ spec = focus $ it "Recognizes 'Create' transition" \spotGarbage -> do Oura.withOura (Oura.MkWorkDir "./tmp") spotGarbage \oura -> do let - params = Auction.MkAuctionParams - { seller = "e01bb07f0cd514c0b8b73572e8c5e7492449c5f68702fdac758225f4" -- "e01bb07f0cd514c0b8b73572e8c5e7492449c5f68702fdac758225f4" - , lot = V1.Value.assetClassValue - (V1.Value.assetClass - "94906060606060606060606060606060606060606060606969669696" - "fea6" - ) - 4 - } - flip shouldBe 28 - $ BS.length - -- $ Base16.decodeBase16 - -- $ Base16.Types.assertBase16 - $ PlutusLedgerApi.V1.fromBuiltin - $ PlutusLedgerApi.V1.getPubKeyHash params.seller + params = + Auction.MkAuctionParams + { seller = "e01bb07f0cd514c0b8b73572e8c5e7492449c5f68702fdac758225f4" -- "e01bb07f0cd514c0b8b73572e8c5e7492449c5f68702fdac758225f4" + , lot = + V1.Value.assetClassValue + ( V1.Value.assetClass + "94906060606060606060606060606060606060606060606969669696" + "fea6" + ) + 4 + } + flip shouldBe 28 $ + BS.length + -- \$ Base16.decodeBase16 + -- \$ Base16.Types.assertBase16 + $ + PlutusLedgerApi.V1.fromBuiltin $ + PlutusLedgerApi.V1.getPubKeyHash params.seller let - rightTxHash = Mock.MkBlake2b255Hex - "2266778888888888888888888888888888888888888888888888444444444444" - tx = Mock.txToText - $ Mock.mkTxEvent - $ Mock.hash .~ rightTxHash - $ createTxMock params + rightTxHash = + Mock.MkBlake2b255Hex + "2266778888888888888888888888888888888888888888888888444444444444" + tx = + Mock.txToText $ + Mock.mkTxEvent $ + Mock.hash .~ rightTxHash $ + createTxMock params unmatchingTx = Mock.txToText $ Mock.mkTxEvent Mock.arbitraryTx putStrLn "evaluating" - print $ plutusAaddressToOuraAddress $ - PlutusLedgerApi.V1.Address - (PlutusLedgerApi.V1.PubKeyCredential params.seller) - Nothing + print $ + plutusAaddressToOuraAddress $ + PlutusLedgerApi.V1.Address + (PlutusLedgerApi.V1.PubKeyCredential params.seller) + Nothing putStrLn "good" oura.send unmatchingTx putStrLn "Sent1" oura.send tx putStrLn "Sent2" - Right txEvent <- Aeson.eitherDecodeStrictText @Mock.TxEvent - <$> oura.receive + Right txEvent <- + Aeson.eitherDecodeStrictText @Mock.TxEvent + <$> oura.receive (txEvent ^. Mock.parsed_tx . Mock.hash) `shouldBe` rightTxHash oura.shutDown it "Recognizes 'Start' transition" \spotGarbage -> do @@ -95,7 +102,7 @@ spec = it "Recognizes 'Buyout' transition" \spotGarbage -> do fail @IO @() "Not implemented" -plutusAaddressToOuraAddress :: HasCallStack => PlutusLedgerApi.V1.Address -> Mock.Address +plutusAaddressToOuraAddress :: (HasCallStack) => PlutusLedgerApi.V1.Address -> Mock.Address plutusAaddressToOuraAddress (PlutusLedgerApi.V1.Address payment stake) = Mock.MkAddressAsBase64 $ Base64.extractBase64 $ @@ -103,12 +110,14 @@ plutusAaddressToOuraAddress (PlutusLedgerApi.V1.Address payment stake) = SerialiseRaw.serialiseToRawBytes $ Address.ShelleyAddress Ledger.Mainnet - (fromMaybe - (error "plutusAaddressToOuraAddress:can't decode payment credential") - paymentCredential) - (fromMaybe - (error "plutusAaddressToOuraAddress:can't decode stake credential") - stakeCredential) + ( fromMaybe + (error "plutusAaddressToOuraAddress:can't decode payment credential") + paymentCredential + ) + ( fromMaybe + (error "plutusAaddressToOuraAddress:can't decode stake credential") + stakeCredential + ) where credentialToCardano ( PlutusLedgerApi.V1.PubKeyCredential @@ -159,26 +168,30 @@ createTxMock params = } , Mock._tx_hash = Mock.MkBlake2b255Hex "af6366838cfac9cc56856ffe1d595ad1dd32c9bafb1ca064a08b5c687293110f" , Mock._output_index = 0 - , Mock._redeemer = Just - $ Mock.MkRedeemer - { _purpose = Mock.PURPOSE_SPEND - , datum = Mock.encodePlutusData - $ PlutusLedgerApi.V1.toData Auction.Create - } + , Mock._redeemer = + Just $ + Mock.MkRedeemer + { _purpose = Mock.PURPOSE_SPEND + , datum = + Mock.encodePlutusData $ + PlutusLedgerApi.V1.toData Auction.Create + } + } + output = + Mock.MkTxOutput + { Mock._address = + plutusAaddressToOuraAddress $ + PlutusLedgerApi.V1.Address + (PlutusLedgerApi.V1.PubKeyCredential params.seller) + Nothing + , Mock._datum = + Just $ + Mock.encodePlutusData $ + PlutusLedgerApi.V1.toData outputState + , Mock._coin = 2 + , Mock._script = Nothing + , Mock._assets = valueToMultiAsset params.lot } - output = Mock.MkTxOutput - { Mock._address = - plutusAaddressToOuraAddress $ - PlutusLedgerApi.V1.Address - (PlutusLedgerApi.V1.PubKeyCredential params.seller) - Nothing - , Mock._datum = Just - $ Mock.encodePlutusData - $ PlutusLedgerApi.V1.toData outputState - , Mock._coin = 2 - , Mock._script = Nothing - , Mock._assets = valueToMultiAsset params.lot - } valueToMultiAsset :: PlutusLedgerApi.V1.Value -> [Mock.Multiasset] valueToMultiAsset = PlutusLedgerApi.V1.getValue >>> AssocMap.toList >>> fmap \(cs, tokens) -> diff --git a/test/OuraFilters/Mock.hs b/test/OuraFilters/Mock.hs index 3b8cf19..594142e 100644 --- a/test/OuraFilters/Mock.hs +++ b/test/OuraFilters/Mock.hs @@ -7,6 +7,7 @@ module OuraFilters.Mock where import Control.Lens.TH (makeLenses, makeLensesFor) +import Control.Monad ((<=<)) import Data.Aeson (KeyValue ((.=))) import Data.Aeson qualified as Aeson import Data.Base64.Types qualified as Base64.Types @@ -19,10 +20,9 @@ import Data.Text.Encoding qualified as T.Encoding import Data.Vector qualified as Vec import GHC.Generics (Generic (Rep)) import PlutusLedgerApi.V1 qualified +import Safe qualified import Utils (digits) import Prelude -import qualified Safe -import Control.Monad ((<=<)) newtype WithoutUnderscore a = MkWithoutUnderscore a deriving newtype (Generic) @@ -102,7 +102,8 @@ data Purpose instance Aeson.FromJSON Purpose where parseJSON = maybe (fail "There is no Purpose case with this Id") pure - . Safe.toEnumMay <=< Aeson.parseJSON @Int + . Safe.toEnumMay + <=< Aeson.parseJSON @Int instance Aeson.ToJSON Purpose where toJSON = Aeson.toJSON @Int . fromEnum diff --git a/test/Utils.hs b/test/Utils.hs index 3587907..f3bd146 100644 --- a/test/Utils.hs +++ b/test/Utils.hs @@ -45,6 +45,7 @@ import Cardano.Extras import Data.Spine (HasSpine (..)) import Control.Exception (bracket) +import Data.Aeson.Types qualified as Aeson import Data.Foldable (traverse_) import Data.IORef qualified as IORef import System.Directory (removeFile) @@ -52,7 +53,6 @@ import System.IO (hClose, openTempFile) import System.Process qualified as Process import Test.Hspec qualified as Hspec import TestNFT -import qualified Data.Aeson.Types as Aeson resultToEither :: Aeson.Result a -> Either String a resultToEither (Aeson.Success a) = Right a From a9360670e8292c9f981e4dd78287c1774aeeae97 Mon Sep 17 00:00:00 2001 From: Renegatto Date: Thu, 12 Sep 2024 22:06:52 +0300 Subject: [PATCH 17/36] Use BS instead of Text; Encode hash as base16 hex instead of UTF8 --- test/Oura.hs | 11 ++++------- test/Oura/Communication.hs | 8 ++++---- test/OuraFilters.hs | 13 +++++++------ test/OuraFilters/Auction.hs | 24 +++++++++++++----------- test/OuraFilters/Mock.hs | 14 ++++++++------ 5 files changed, 36 insertions(+), 34 deletions(-) diff --git a/test/Oura.hs b/test/Oura.hs index 6dcab7f..00f0a7f 100644 --- a/test/Oura.hs +++ b/test/Oura.hs @@ -24,7 +24,7 @@ import Utils qualified import Control.Concurrent.Async (Async) import Control.Concurrent.Async qualified as Async -import Data.Text.Encoding qualified as Text.Encoding +import Data.ByteString qualified as BS import Oura.Communication qualified as Communication import Oura.Config qualified as Config import System.Directory (removeFile) @@ -36,8 +36,8 @@ 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} @@ -89,10 +89,7 @@ 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 diff --git a/test/Oura/Communication.hs b/test/Oura/Communication.hs index 19fafa2..af3d384 100644 --- a/test/Oura/Communication.hs +++ b/test/Oura/Communication.hs @@ -27,11 +27,11 @@ 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 Data.ByteString.Char8 qualified as BS.Char8 import Oura.Config (SinkPath, SourcePath (MkSourcePath), unSinkPath) data OuraDaemonConnection = MkOuraDaemonConnection @@ -72,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 } @@ -96,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 @@ -112,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/OuraFilters.hs b/test/OuraFilters.hs index 0e997de..d8e0bd7 100644 --- a/test/OuraFilters.hs +++ b/test/OuraFilters.hs @@ -8,6 +8,7 @@ import Control.Monad ((>=>)) 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)) @@ -73,8 +74,8 @@ ouraFiltersSpec = Utils.killProcessesOnError do focus $ it "Oura filters match tx it have to match, and don't match other" \spotGarbage -> do Oura.withOura (Oura.MkWorkDir "./tmp") spotGarbage \oura -> do let - tx = Mock.txToText exampleTx - matchingTx = Mock.txToText exampleMatchingTx + tx = Mock.txToBS exampleTx + matchingTx = Mock.txToBS exampleMatchingTx oura.send tx -- _ <- oura.receive oura.send matchingTx @@ -86,14 +87,14 @@ ouraFiltersSpec = Utils.killProcessesOnError do oura.shutDown OuraFilters.Auction.spec -extractInputTxHash :: T.Text -> Either String T.Text +extractInputTxHash :: BS.ByteString -> Either String T.Text extractInputTxHash = - Aeson.eitherDecodeStrictText >=> Aeson.parseEither \json -> do + Aeson.eitherDecodeStrict >=> Aeson.parseEither \json -> do parsedTx <- json .: "parsed_tx" parsedTx .: "hash" -extractOutputTxHash :: T.Text -> Either String T.Text +extractOutputTxHash :: BS.ByteString -> Either String T.Text extractOutputTxHash = - Aeson.eitherDecodeStrictText >=> Aeson.parseEither \json -> do + Aeson.eitherDecodeStrict >=> Aeson.parseEither \json -> do parsedTx <- json .: "record" parsedTx .: "hash" diff --git a/test/OuraFilters/Auction.hs b/test/OuraFilters/Auction.hs index 22f1e3a..28bb625 100644 --- a/test/OuraFilters/Auction.hs +++ b/test/OuraFilters/Auction.hs @@ -55,8 +55,8 @@ spec = , lot = V1.Value.assetClassValue ( V1.Value.assetClass - "94906060606060606060606060606060606060606060606969669696" - "fea6" + "e01bb07f0cd514c0b8b73572e8c5e7492449c5f68702fdac758225f4" + "" ) 4 } @@ -72,11 +72,11 @@ spec = Mock.MkBlake2b255Hex "2266778888888888888888888888888888888888888888888888444444444444" tx = - Mock.txToText $ + Mock.txToBS $ Mock.mkTxEvent $ Mock.hash .~ rightTxHash $ createTxMock params - unmatchingTx = Mock.txToText $ Mock.mkTxEvent Mock.arbitraryTx + unmatchingTx = Mock.txToBS $ Mock.mkTxEvent Mock.arbitraryTx putStrLn "evaluating" print $ plutusAaddressToOuraAddress $ @@ -89,7 +89,7 @@ spec = oura.send tx putStrLn "Sent2" Right txEvent <- - Aeson.eitherDecodeStrictText @Mock.TxEvent + Aeson.eitherDecodeStrict @Mock.TxEvent <$> oura.receive (txEvent ^. Mock.parsed_tx . Mock.hash) `shouldBe` rightTxHash oura.shutDown @@ -197,16 +197,18 @@ createTxMock params = PlutusLedgerApi.V1.getValue >>> AssocMap.toList >>> fmap \(cs, tokens) -> Mock.MkMultiasset { Mock._policy_id = - T.Encoding.decodeUtf8 $ - PlutusLedgerApi.V1.fromBuiltin $ - PlutusLedgerApi.V1.unCurrencySymbol cs + Base16.Types.extractBase16 $ + Base16.encodeBase16 $ + PlutusLedgerApi.V1.fromBuiltin $ + PlutusLedgerApi.V1.unCurrencySymbol cs , Mock.assets = AssocMap.toList tokens <&> \(tn, amt) -> Mock.MkAsset { Mock._name = - T.Encoding.decodeUtf8 $ - PlutusLedgerApi.V1.fromBuiltin $ - PlutusLedgerApi.V1.unTokenName tn + Base16.Types.extractBase16 $ + Base16.encodeBase16 $ + PlutusLedgerApi.V1.fromBuiltin $ + PlutusLedgerApi.V1.unTokenName tn , Mock._output_coin = amt -- positive , Mock._mint_coin = 1 } diff --git a/test/OuraFilters/Mock.hs b/test/OuraFilters/Mock.hs index 594142e..9a6e7da 100644 --- a/test/OuraFilters/Mock.hs +++ b/test/OuraFilters/Mock.hs @@ -16,7 +16,6 @@ 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.Text.Encoding qualified as T.Encoding import Data.Vector qualified as Vec import GHC.Generics (Generic (Rep)) import PlutusLedgerApi.V1 qualified @@ -260,11 +259,14 @@ mkTxEvent _parsed_tx = , _point = "Origin" } -txToText :: TxEvent -> T.Text -txToText = - T.Encoding.decodeUtf8 - . LBS.toStrict - . Aeson.encode +-- txToText :: TxEvent -> T.Text +-- txToText = +-- T.Encoding.decodeUtf8 +-- . LBS.toStrict +-- . Aeson.encode + +txToBS :: TxEvent -> BS.ByteString +txToBS = LBS.toStrict . Aeson.encode encodePlutusData :: PlutusLedgerApi.V1.Data -> PlutusData encodePlutusData = MkPlutusData . datumToJson From a2cf4b752852b2ed2d772117fa0793597d3d9927 Mon Sep 17 00:00:00 2001 From: Renegatto Date: Fri, 13 Sep 2024 00:14:51 +0300 Subject: [PATCH 18/36] Move serialization logic to Mock.hs --- test/OuraFilters/Auction.hs | 108 +++--------------------------------- test/OuraFilters/Mock.hs | 89 +++++++++++++++++++++++++++-- 2 files changed, 94 insertions(+), 103 deletions(-) diff --git a/test/OuraFilters/Auction.hs b/test/OuraFilters/Auction.hs index 28bb625..2a664ef 100644 --- a/test/OuraFilters/Auction.hs +++ b/test/OuraFilters/Auction.hs @@ -1,46 +1,24 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE PackageImports #-} module OuraFilters.Auction (spec) where -import Cardano.Api.Ledger qualified -import Cardano.Api.SerialiseRaw qualified as SerialiseRaw import Cardano.CEM (CEMScriptDatum) -import Cardano.CEM.Examples.Auction (SimpleAuctionState (NotStarted)) import Cardano.CEM.Examples.Auction qualified as Auction -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 Control.Arrow ((>>>)) import Control.Lens ((%~), (.~), (^.)) 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.Base32 qualified as Base32 -import Data.ByteString.Base64 qualified as BS.Base64 -import Data.ByteString.Base64 qualified as Base64 -import Data.Coerce (coerce) import Data.Function ((&)) import Data.Functor ((<&>)) -import Data.Maybe (fromJust, fromMaybe) -import Data.Text qualified as T -import Data.Text.Encoding qualified as T.Encoding import Oura qualified import OuraFilters.Mock qualified as Mock import PlutusLedgerApi.V1 qualified import PlutusLedgerApi.V1.Value qualified as V1.Value import PlutusTx.AssocMap qualified as AssocMap import System.Process (ProcessHandle) -import Test.Hspec (HasCallStack, describe, focus, it, shouldBe) +import Test.Hspec (describe, focus, it, shouldBe) import Test.Hspec.Core.Spec (SpecM) -import Utils (SpotGarbage, resultToEither) -import "cardano-api" Cardano.Api.Address qualified as Address +import Utils (SpotGarbage) import Prelude spec :: SpecM (SpotGarbage IO ProcessHandle) () @@ -51,23 +29,15 @@ spec = let params = Auction.MkAuctionParams - { seller = "e01bb07f0cd514c0b8b73572e8c5e7492449c5f68702fdac758225f4" -- "e01bb07f0cd514c0b8b73572e8c5e7492449c5f68702fdac758225f4" + { seller = "ab0baab0baab0baab0baab0baab0ba00000000000004444444444444" , lot = V1.Value.assetClassValue ( V1.Value.assetClass - "e01bb07f0cd514c0b8b73572e8c5e7492449c5f68702fdac758225f4" + "eeeeeeeeeeffffffffaaaaaaa4444444444444444444444444444444" "" ) 4 } - flip shouldBe 28 $ - BS.length - -- \$ Base16.decodeBase16 - -- \$ Base16.Types.assertBase16 - $ - PlutusLedgerApi.V1.fromBuiltin $ - PlutusLedgerApi.V1.getPubKeyHash params.seller - let rightTxHash = Mock.MkBlake2b255Hex "2266778888888888888888888888888888888888888888888888444444444444" @@ -77,17 +47,8 @@ spec = Mock.hash .~ rightTxHash $ createTxMock params unmatchingTx = Mock.txToBS $ Mock.mkTxEvent Mock.arbitraryTx - putStrLn "evaluating" - print $ - plutusAaddressToOuraAddress $ - PlutusLedgerApi.V1.Address - (PlutusLedgerApi.V1.PubKeyCredential params.seller) - Nothing - putStrLn "good" oura.send unmatchingTx - putStrLn "Sent1" oura.send tx - putStrLn "Sent2" Right txEvent <- Aeson.eitherDecodeStrict @Mock.TxEvent <$> oura.receive @@ -102,50 +63,6 @@ spec = it "Recognizes 'Buyout' transition" \spotGarbage -> do fail @IO @() "Not implemented" -plutusAaddressToOuraAddress :: (HasCallStack) => PlutusLedgerApi.V1.Address -> Mock.Address -plutusAaddressToOuraAddress (PlutusLedgerApi.V1.Address payment stake) = - Mock.MkAddressAsBase64 $ - Base64.extractBase64 $ - BS.Base64.encodeBase64 $ - SerialiseRaw.serialiseToRawBytes $ - Address.ShelleyAddress - Ledger.Mainnet - ( fromMaybe - (error "plutusAaddressToOuraAddress:can't decode payment credential") - paymentCredential - ) - ( fromMaybe - (error "plutusAaddressToOuraAddress:can't decode stake credential") - stakeCredential - ) - 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 {} -> - error "Staking pointers are not supported" - createTxMock :: Auction.SimpleAuctionParams -> Mock.Tx createTxMock params = Mock.arbitraryTx @@ -157,7 +74,7 @@ createTxMock params = { Mock._as_output = Mock.MkTxOutput { Mock._address = - plutusAaddressToOuraAddress $ + Mock.plutusAddressToOuraAddress $ PlutusLedgerApi.V1.Address (PlutusLedgerApi.V1.PubKeyCredential params.seller) Nothing @@ -180,7 +97,7 @@ createTxMock params = output = Mock.MkTxOutput { Mock._address = - plutusAaddressToOuraAddress $ + Mock.plutusAddressToOuraAddress $ PlutusLedgerApi.V1.Address (PlutusLedgerApi.V1.PubKeyCredential params.seller) Nothing @@ -196,23 +113,16 @@ createTxMock params = valueToMultiAsset = PlutusLedgerApi.V1.getValue >>> AssocMap.toList >>> fmap \(cs, tokens) -> Mock.MkMultiasset - { Mock._policy_id = - Base16.Types.extractBase16 $ - Base16.encodeBase16 $ - PlutusLedgerApi.V1.fromBuiltin $ - PlutusLedgerApi.V1.unCurrencySymbol cs + { Mock._policy_id = Mock.serialiseCurrencySymbol cs , Mock.assets = AssocMap.toList tokens <&> \(tn, amt) -> Mock.MkAsset { Mock._name = - Base16.Types.extractBase16 $ - Base16.encodeBase16 $ - PlutusLedgerApi.V1.fromBuiltin $ - PlutusLedgerApi.V1.unTokenName tn + Mock.serialiseAsHex $ + PlutusLedgerApi.V1.unTokenName tn , Mock._output_coin = amt -- positive , Mock._mint_coin = 1 } - , Mock.redeemer = Nothing } outputState :: CEMScriptDatum Auction.SimpleAuction diff --git a/test/OuraFilters/Mock.hs b/test/OuraFilters/Mock.hs index 9a6e7da..b2c4342 100644 --- a/test/OuraFilters/Mock.hs +++ b/test/OuraFilters/Mock.hs @@ -6,18 +6,32 @@ module OuraFilters.Mock where +import Cardano.Api.Address qualified as Address +import Cardano.Api.Ledger qualified +import Cardano.Api.Ledger qualified as Cred +import Cardano.Api.SerialiseRaw qualified as SerialiseRaw +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 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.Maybe (fromMaybe) 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) @@ -47,14 +61,14 @@ newtype Address = MkAddressAsBase64 T.Text makeLenses ''Address -- 32B long -newtype Hash32 = MkBlake2b255Hex T.Text +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 T.Text +newtype Hash28 = MkBlake2b244Hex {unHash28 :: T.Text} deriving newtype (Show, Eq, Ord) deriving newtype (Aeson.ToJSON) deriving newtype (Aeson.FromJSON) @@ -71,9 +85,9 @@ data Asset = MkAsset makeLenses ''Asset data Multiasset = MkMultiasset - { _policy_id :: T.Text + { _policy_id :: Hash28 , assets :: [Asset] - , redeemer :: Maybe Aeson.Value + -- , redeemer :: Maybe Aeson.Value } deriving stock (Generic) deriving (Aeson.ToJSON) via (WithoutUnderscore Multiasset) @@ -330,3 +344,70 @@ datumToJson = [ "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 (PlutusLedgerApi.V1.Address payment stake) = + MkAddressAsBase64 + . Base64.extractBase64 + . Base64.encodeBase64 + . SerialiseRaw.serialiseToRawBytes + $ Address.ShelleyAddress + Ledger.Mainnet + ( fromMaybe + (error "plutusAaddressToOuraAddress:can't decode payment credential") + paymentCredential + ) + ( fromMaybe + (error "plutusAaddressToOuraAddress:can't decode stake credential") + stakeCredential + ) + 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) From a1000c5dca5daad8effd587dde39b816ab769bdc Mon Sep 17 00:00:00 2001 From: Renegatto Date: Fri, 13 Sep 2024 15:45:34 +0300 Subject: [PATCH 19/36] Clean up --- test/OuraFilters/Mock.hs | 14 ++++---------- 1 file changed, 4 insertions(+), 10 deletions(-) diff --git a/test/OuraFilters/Mock.hs b/test/OuraFilters/Mock.hs index b2c4342..bb1bb4e 100644 --- a/test/OuraFilters/Mock.hs +++ b/test/OuraFilters/Mock.hs @@ -87,7 +87,6 @@ makeLenses ''Asset data Multiasset = MkMultiasset { _policy_id :: Hash28 , assets :: [Asset] - -- , redeemer :: Maybe Aeson.Value } deriving stock (Generic) deriving (Aeson.ToJSON) via (WithoutUnderscore Multiasset) @@ -155,14 +154,15 @@ makeLenses ''TxInput data TxWitnesses = MkTxWitnesses { _vkeywitness :: [Aeson.Value] - , _script :: [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 +makeLenses ''TxWitnesses +makeLensesFor [("script", "txWitnessesScript")] ''Multiasset data TxCollateral = MkTxCollateral { _collateral :: [Aeson.Value] @@ -204,7 +204,7 @@ arbitraryTx = , _witnesses = MkTxWitnesses { _vkeywitness = [] - , _script = [] + , script = [] , _plutus_datums = [] } , collateral = @@ -273,12 +273,6 @@ mkTxEvent _parsed_tx = , _point = "Origin" } --- txToText :: TxEvent -> T.Text --- txToText = --- T.Encoding.decodeUtf8 --- . LBS.toStrict --- . Aeson.encode - txToBS :: TxEvent -> BS.ByteString txToBS = LBS.toStrict . Aeson.encode From 193b3575ea95cb1a1c727eef6c19be44703ca00b Mon Sep 17 00:00:00 2001 From: Renegatto Date: Fri, 13 Sep 2024 16:07:03 +0300 Subject: [PATCH 20/36] Set timeouts on the oura tests --- test/OuraFilters.hs | 18 +++++++++--------- test/OuraFilters/Auction.hs | 21 ++++++++++++--------- test/Utils.hs | 7 +++++++ 3 files changed, 28 insertions(+), 18 deletions(-) diff --git a/test/OuraFilters.hs b/test/OuraFilters.hs index d8e0bd7..d92e227 100644 --- a/test/OuraFilters.hs +++ b/test/OuraFilters.hs @@ -76,15 +76,15 @@ ouraFiltersSpec = Utils.killProcessesOnError do let tx = Mock.txToBS exampleTx matchingTx = Mock.txToBS exampleMatchingTx - oura.send tx - -- _ <- oura.receive - oura.send matchingTx - Right outTxHash <- - extractOutputTxHash <$> oura.receive - Right inputTxHash <- - pure $ extractInputTxHash matchingTx - outTxHash `shouldBe` inputTxHash - oura.shutDown + 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 diff --git a/test/OuraFilters/Auction.hs b/test/OuraFilters/Auction.hs index 2a664ef..747d400 100644 --- a/test/OuraFilters/Auction.hs +++ b/test/OuraFilters/Auction.hs @@ -9,16 +9,17 @@ import Control.Arrow ((>>>)) import Control.Lens ((%~), (.~), (^.)) import Data.Aeson qualified as Aeson import Data.Function ((&)) -import Data.Functor ((<&>)) +import Data.Functor (void, (<&>)) import Oura qualified import OuraFilters.Mock qualified as Mock import PlutusLedgerApi.V1 qualified import PlutusLedgerApi.V1.Value qualified as V1.Value import PlutusTx.AssocMap qualified as AssocMap import System.Process (ProcessHandle) +import System.Timeout (timeout) import Test.Hspec (describe, focus, it, shouldBe) import Test.Hspec.Core.Spec (SpecM) -import Utils (SpotGarbage) +import Utils (SpotGarbage, withTimeout) import Prelude spec :: SpecM (SpotGarbage IO ProcessHandle) () @@ -47,13 +48,15 @@ spec = Mock.hash .~ rightTxHash $ createTxMock params unmatchingTx = Mock.txToBS $ Mock.mkTxEvent Mock.arbitraryTx - oura.send unmatchingTx - oura.send tx - Right txEvent <- - Aeson.eitherDecodeStrict @Mock.TxEvent - <$> oura.receive - (txEvent ^. Mock.parsed_tx . Mock.hash) `shouldBe` rightTxHash - oura.shutDown + withTimeout 3.0 do + oura.send unmatchingTx + oura.send tx + -- 2 sec + Right txEvent <- + Aeson.eitherDecodeStrict @Mock.TxEvent + <$> oura.receive + (txEvent ^. Mock.parsed_tx . Mock.hash) `shouldBe` rightTxHash + oura.shutDown it "Recognizes 'Start' transition" \spotGarbage -> do fail @IO @() "Not implemented" it "Recognizes 'MakeBid' transition" \spotGarbage -> do diff --git a/test/Utils.hs b/test/Utils.hs index f3bd146..65d1fa8 100644 --- a/test/Utils.hs +++ b/test/Utils.hs @@ -45,15 +45,22 @@ 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 +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 From 7a3dd8dd7b866fff1cfbd57e5a7921efc5c7a94f Mon Sep 17 00:00:00 2001 From: Renegatto Date: Sat, 14 Sep 2024 20:36:04 +0300 Subject: [PATCH 21/36] WIP: Make simple indexer test --- test/OuraFilters/Auction.hs | 127 ++++++++++++++++++++++++------------ 1 file changed, 85 insertions(+), 42 deletions(-) diff --git a/test/OuraFilters/Auction.hs b/test/OuraFilters/Auction.hs index 747d400..f0e637f 100644 --- a/test/OuraFilters/Auction.hs +++ b/test/OuraFilters/Auction.hs @@ -6,7 +6,7 @@ module OuraFilters.Auction (spec) where import Cardano.CEM (CEMScriptDatum) import Cardano.CEM.Examples.Auction qualified as Auction import Control.Arrow ((>>>)) -import Control.Lens ((%~), (.~), (^.)) +import Control.Lens ((%~), (.~), (?~), (^.)) import Data.Aeson qualified as Aeson import Data.Function ((&)) import Data.Functor (void, (<&>)) @@ -24,8 +24,42 @@ import Prelude spec :: SpecM (SpotGarbage IO ProcessHandle) () spec = + -- @(SpotGarbage IO ProcessHandle) describe "Auction example" do - focus $ it "Recognizes 'Create' transition" \spotGarbage -> do + focus $ it "Catches any Auction validator transition" \spotGarbage -> do + Oura.withOura @() (Oura.MkWorkDir "./tmp") spotGarbage \oura -> do + let + -- auction = undefined + auctionPaymentCredential = undefined + -- we want oura to monitor just payment credential, ignoring stake credentials + arbitraryStakeCredential = PlutusLedgerApi.V1.StakingPtr 5 3 2 + defaultTx = Mock.arbitraryTx + rightTxHash = + Mock.MkBlake2b255Hex + "2266778888888888888888888888888888888888888888888888444444444444" + inputFromValidator = + emptyInputFixture auctionPaymentCredential (Just arbitraryStakeCredential) + + tx = + Mock.txToBS + . Mock.mkTxEvent + . (Mock.inputs %~ (inputFromValidator :)) + . (Mock.hash .~ rightTxHash) + $ defaultTx + unmatchingTx = + Mock.txToBS + . Mock.mkTxEvent + $ Mock.arbitraryTx + + withTimeout 3.0 do + oura.send unmatchingTx + oura.send tx + Right txEvent <- + Aeson.eitherDecodeStrict @Mock.TxEvent + <$> oura.receive + (txEvent ^. Mock.parsed_tx . Mock.hash) `shouldBe` rightTxHash + oura.shutDown + it "Recognizes 'Create' transition" \spotGarbage -> do Oura.withOura (Oura.MkWorkDir "./tmp") spotGarbage \oura -> do let params = @@ -51,7 +85,6 @@ spec = withTimeout 3.0 do oura.send unmatchingTx oura.send tx - -- 2 sec Right txEvent <- Aeson.eitherDecodeStrict @Mock.TxEvent <$> oura.receive @@ -73,30 +106,18 @@ createTxMock params = & Mock.outputs %~ (:) output where input = - Mock.MkTxInput - { Mock._as_output = - Mock.MkTxOutput - { Mock._address = - Mock.plutusAddressToOuraAddress $ - PlutusLedgerApi.V1.Address - (PlutusLedgerApi.V1.PubKeyCredential params.seller) - Nothing - , Mock._datum = Nothing -- any datum - , Mock._coin = 2 - , Mock._script = Nothing - , Mock._assets = valueToMultiAsset params.lot - } - , Mock._tx_hash = Mock.MkBlake2b255Hex "af6366838cfac9cc56856ffe1d595ad1dd32c9bafb1ca064a08b5c687293110f" - , Mock._output_index = 0 - , Mock._redeemer = - Just $ - Mock.MkRedeemer - { _purpose = Mock.PURPOSE_SPEND - , datum = - Mock.encodePlutusData $ - PlutusLedgerApi.V1.toData Auction.Create - } - } + emptyInputFixture + (PlutusLedgerApi.V1.PubKeyCredential params.seller) + Nothing + & Mock.as_output . Mock.assets .~ valueToMultiAsset params.lot + & Mock.redeemer + ?~ Mock.MkRedeemer + { _purpose = Mock.PURPOSE_SPEND + , datum = + Mock.encodePlutusData $ + PlutusLedgerApi.V1.toData Auction.Create + } + output = Mock.MkTxOutput { Mock._address = @@ -112,21 +133,43 @@ createTxMock params = , Mock._script = Nothing , Mock._assets = valueToMultiAsset params.lot } - valueToMultiAsset :: PlutusLedgerApi.V1.Value -> [Mock.Multiasset] - valueToMultiAsset = - PlutusLedgerApi.V1.getValue >>> AssocMap.toList >>> fmap \(cs, tokens) -> - Mock.MkMultiasset - { Mock._policy_id = Mock.serialiseCurrencySymbol cs - , Mock.assets = - AssocMap.toList tokens <&> \(tn, amt) -> - Mock.MkAsset - { Mock._name = - Mock.serialiseAsHex $ - PlutusLedgerApi.V1.unTokenName tn - , Mock._output_coin = amt -- positive - , Mock._mint_coin = 1 - } - } outputState :: CEMScriptDatum Auction.SimpleAuction outputState = (Auction.NoControl, params, Auction.NotStarted) + +valueToMultiAsset :: PlutusLedgerApi.V1.Value -> [Mock.Multiasset] +valueToMultiAsset = + PlutusLedgerApi.V1.getValue >>> AssocMap.toList >>> fmap \(cs, tokens) -> + Mock.MkMultiasset + { Mock._policy_id = Mock.serialiseCurrencySymbol cs + , Mock.assets = + AssocMap.toList tokens <&> \(tn, amt) -> + Mock.MkAsset + { Mock._name = + Mock.serialiseAsHex $ + PlutusLedgerApi.V1.unTokenName tn + , Mock._output_coin = amt -- positive + , Mock._mint_coin = 1 + } + } + +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 + } From 38f5c2cc756a1177252701bc64bfa3f508f167aa Mon Sep 17 00:00:00 2001 From: Renegatto Date: Sat, 14 Sep 2024 20:45:38 +0300 Subject: [PATCH 22/36] Finish test --- test/OuraFilters/Auction.hs | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/test/OuraFilters/Auction.hs b/test/OuraFilters/Auction.hs index f0e637f..f6f7738 100644 --- a/test/OuraFilters/Auction.hs +++ b/test/OuraFilters/Auction.hs @@ -5,13 +5,17 @@ module OuraFilters.Auction (spec) where import Cardano.CEM (CEMScriptDatum) import Cardano.CEM.Examples.Auction qualified as Auction +import Cardano.CEM.Examples.Compilation () +import Cardano.CEM.OnChain qualified as Compiled import Control.Arrow ((>>>)) import Control.Lens ((%~), (.~), (?~), (^.)) import Data.Aeson qualified as Aeson +import Data.Data (Proxy (Proxy)) import Data.Function ((&)) import Data.Functor (void, (<&>)) import Oura qualified import OuraFilters.Mock qualified as Mock +import Plutus.Extras (scriptValidatorHash) import PlutusLedgerApi.V1 qualified import PlutusLedgerApi.V1.Value qualified as V1.Value import PlutusTx.AssocMap qualified as AssocMap @@ -29,8 +33,11 @@ spec = focus $ it "Catches any Auction validator transition" \spotGarbage -> do Oura.withOura @() (Oura.MkWorkDir "./tmp") spotGarbage \oura -> do let - -- auction = undefined - auctionPaymentCredential = undefined + auctionPaymentCredential = + PlutusLedgerApi.V1.ScriptCredential + . scriptValidatorHash + . Compiled.cemScriptCompiled + $ Proxy @Auction.SimpleAuction -- we want oura to monitor just payment credential, ignoring stake credentials arbitraryStakeCredential = PlutusLedgerApi.V1.StakingPtr 5 3 2 defaultTx = Mock.arbitraryTx From bf3a4d6abeef129c316e785e44e5b5a36603fe94 Mon Sep 17 00:00:00 2001 From: Renegatto Date: Sat, 14 Sep 2024 22:26:21 +0300 Subject: [PATCH 23/36] Make lenses for Toml to edit oura config --- test/Oura/Config.hs | 63 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 63 insertions(+) diff --git a/test/Oura/Config.hs b/test/Oura/Config.hs index 7121b2c..91fdcf6 100644 --- a/test/Oura/Config.hs +++ b/test/Oura/Config.hs @@ -1,11 +1,33 @@ +{-# LANGUAGE BlockArguments #-} + module Oura.Config ( daemonConfig, SourcePath (MkSourcePath, unSourcePath), SinkPath (MkSinkPath, unSinkPath), + filtersL, + tableL, + atKey, + _Table, + _Integer, + _Bool, + _Text, ) where import Prelude +import Control.Lens ( + At (at), + Each (each), + Lens', + Prism', + Traversal', + iso, + mapping, + partsOf, + prism', + _Just, + ) +import Data.Map (Map) import Data.String (IsString) import Data.Text qualified as T import Toml qualified @@ -72,3 +94,44 @@ source (MkSourcePath socketPath) = [ "socket_path" .= Toml.Text socketPath , "type" .= Toml.Text "TxOverSocket" ] + +filtersL :: Traversal' Toml.Value [Toml.Table] +filtersL = + _Table + . atKey "filters" + . _Just + . _List + . partsOf (each . _Table) + +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 From 7d4983bfa7f44b7c4a267efb1bbc3377421c145e Mon Sep 17 00:00:00 2001 From: Renegatto Date: Sun, 15 Sep 2024 15:34:37 +0300 Subject: [PATCH 24/36] Use custom configs in oura tests --- test/Oura.hs | 15 ++-- test/OuraFilters.hs | 29 +++---- test/OuraFilters/Auction.hs | 146 +++++++++++++++++++----------------- 3 files changed, 101 insertions(+), 89 deletions(-) diff --git a/test/Oura.hs b/test/Oura.hs index 00f0a7f..9cdcd04 100644 --- a/test/Oura.hs +++ b/test/Oura.hs @@ -28,6 +28,7 @@ import Data.ByteString qualified as BS import Oura.Communication qualified as Communication import Oura.Config qualified as Config import System.Directory (removeFile) +import Toml (Table) {- | A time required for oura to start up and create a socket, in microseconds. @@ -46,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 @@ -70,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 @@ -92,8 +95,8 @@ runOura (MkWorkDir (T.unpack -> workdir)) spotHandle outputCheckingInterval = do 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 -> diff --git a/test/OuraFilters.hs b/test/OuraFilters.hs index d92e227..bb302a0 100644 --- a/test/OuraFilters.hs +++ b/test/OuraFilters.hs @@ -71,20 +71,21 @@ exampleTx = ouraFiltersSpec :: Spec ouraFiltersSpec = Utils.killProcessesOnError do - focus $ it "Oura filters match tx it have to match, and don't match other" \spotGarbage -> do - Oura.withOura (Oura.MkWorkDir "./tmp") spotGarbage \oura -> do - let - tx = Mock.txToBS exampleTx - matchingTx = Mock.txToBS exampleMatchingTx - 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 + 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 undefined \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 diff --git a/test/OuraFilters/Auction.hs b/test/OuraFilters/Auction.hs index f6f7738..399e2ed 100644 --- a/test/OuraFilters/Auction.hs +++ b/test/OuraFilters/Auction.hs @@ -12,91 +12,99 @@ import Control.Lens ((%~), (.~), (?~), (^.)) import Data.Aeson qualified as Aeson import Data.Data (Proxy (Proxy)) import Data.Function ((&)) -import Data.Functor (void, (<&>)) +import Data.Functor ((<&>)) import Oura qualified +import Oura.Config qualified as Config import OuraFilters.Mock qualified as Mock import Plutus.Extras (scriptValidatorHash) import PlutusLedgerApi.V1 qualified import PlutusLedgerApi.V1.Value qualified as V1.Value import PlutusTx.AssocMap qualified as AssocMap import System.Process (ProcessHandle) -import System.Timeout (timeout) import Test.Hspec (describe, focus, it, shouldBe) import Test.Hspec.Core.Spec (SpecM) +import Toml qualified import Utils (SpotGarbage, withTimeout) import Prelude spec :: SpecM (SpotGarbage IO ProcessHandle) () spec = - -- @(SpotGarbage IO ProcessHandle) + -- describe "Auction example" do - focus $ it "Catches any Auction validator transition" \spotGarbage -> do - Oura.withOura @() (Oura.MkWorkDir "./tmp") spotGarbage \oura -> do - let - auctionPaymentCredential = - PlutusLedgerApi.V1.ScriptCredential - . scriptValidatorHash - . Compiled.cemScriptCompiled - $ Proxy @Auction.SimpleAuction - -- we want oura to monitor just payment credential, ignoring stake credentials - arbitraryStakeCredential = PlutusLedgerApi.V1.StakingPtr 5 3 2 - defaultTx = Mock.arbitraryTx - rightTxHash = - Mock.MkBlake2b255Hex - "2266778888888888888888888888888888888888888888888888444444444444" - inputFromValidator = - emptyInputFixture auctionPaymentCredential (Just arbitraryStakeCredential) + -- @(SpotGarbage IO ProcessHandle) + focus $ it "Catches any Auction validator transition" \spotGarbage -> + let + auctionPaymentCredential = + PlutusLedgerApi.V1.ScriptCredential + . scriptValidatorHash + . Compiled.cemScriptCompiled + $ Proxy @Auction.SimpleAuction + -- we want oura to monitor just payment credential, ignoring stake credentials + arbitraryStakeCredential = PlutusLedgerApi.V1.StakingPtr 5 3 2 + auctionOuraFilters = error "Not implemented" + defaultTx = Mock.arbitraryTx + rightTxHash = + Mock.MkBlake2b255Hex + "2266778888888888888888888888888888888888888888888888444444444444" + inputFromValidator = + emptyInputFixture auctionPaymentCredential (Just arbitraryStakeCredential) - tx = - Mock.txToBS - . Mock.mkTxEvent - . (Mock.inputs %~ (inputFromValidator :)) - . (Mock.hash .~ rightTxHash) - $ defaultTx - unmatchingTx = - Mock.txToBS - . Mock.mkTxEvent - $ Mock.arbitraryTx - - withTimeout 3.0 do - oura.send unmatchingTx - oura.send tx - Right txEvent <- - Aeson.eitherDecodeStrict @Mock.TxEvent - <$> oura.receive - (txEvent ^. Mock.parsed_tx . Mock.hash) `shouldBe` rightTxHash - oura.shutDown - it "Recognizes 'Create' transition" \spotGarbage -> do - Oura.withOura (Oura.MkWorkDir "./tmp") spotGarbage \oura -> do - let - params = - Auction.MkAuctionParams - { seller = "ab0baab0baab0baab0baab0baab0ba00000000000004444444444444" - , lot = - V1.Value.assetClassValue - ( V1.Value.assetClass - "eeeeeeeeeeffffffffaaaaaaa4444444444444444444444444444444" - "" - ) - 4 - } - rightTxHash = - Mock.MkBlake2b255Hex - "2266778888888888888888888888888888888888888888888888444444444444" - tx = - Mock.txToBS $ - Mock.mkTxEvent $ - Mock.hash .~ rightTxHash $ - createTxMock params - unmatchingTx = Mock.txToBS $ Mock.mkTxEvent Mock.arbitraryTx - withTimeout 3.0 do - oura.send unmatchingTx - oura.send tx - Right txEvent <- - Aeson.eitherDecodeStrict @Mock.TxEvent - <$> oura.receive - (txEvent ^. Mock.parsed_tx . Mock.hash) `shouldBe` rightTxHash - oura.shutDown + tx = + Mock.txToBS + . Mock.mkTxEvent + . (Mock.inputs %~ (inputFromValidator :)) + . (Mock.hash .~ rightTxHash) + $ defaultTx + unmatchingTx = + Mock.txToBS + . Mock.mkTxEvent + $ Mock.arbitraryTx + makeConfig :: Config.SourcePath -> Config.SinkPath -> Toml.Table + makeConfig sourcePath sinkPath = + Config.daemonConfig sourcePath sinkPath + & Config.filtersL .~ auctionOuraFilters + in + Oura.withOura (Oura.MkWorkDir "./tmp") spotGarbage makeConfig \oura -> do + withTimeout 3.0 do + oura.send unmatchingTx + oura.send tx + Right txEvent <- + Aeson.eitherDecodeStrict @Mock.TxEvent + <$> oura.receive + (txEvent ^. Mock.parsed_tx . Mock.hash) `shouldBe` rightTxHash + oura.shutDown + it "Recognizes 'Create' transition" \spotGarbage -> + let + params = + Auction.MkAuctionParams + { seller = "ab0baab0baab0baab0baab0baab0ba00000000000004444444444444" + , lot = + V1.Value.assetClassValue + ( V1.Value.assetClass + "eeeeeeeeeeffffffffaaaaaaa4444444444444444444444444444444" + "" + ) + 4 + } + rightTxHash = + Mock.MkBlake2b255Hex + "2266778888888888888888888888888888888888888888888888444444444444" + tx = + Mock.txToBS $ + Mock.mkTxEvent $ + Mock.hash .~ rightTxHash $ + createTxMock params + unmatchingTx = Mock.txToBS $ Mock.mkTxEvent Mock.arbitraryTx + in + Oura.withOura (Oura.MkWorkDir "./tmp") spotGarbage makeConfig \oura -> do + withTimeout 3.0 do + oura.send unmatchingTx + oura.send tx + Right txEvent <- + Aeson.eitherDecodeStrict @Mock.TxEvent + <$> oura.receive + (txEvent ^. Mock.parsed_tx . Mock.hash) `shouldBe` rightTxHash + oura.shutDown it "Recognizes 'Start' transition" \spotGarbage -> do fail @IO @() "Not implemented" it "Recognizes 'MakeBid' transition" \spotGarbage -> do From 7494b2878ed1cc699daf02e9bca680f4ed6d3888 Mon Sep 17 00:00:00 2001 From: Renegatto Date: Mon, 16 Sep 2024 16:48:36 +0300 Subject: [PATCH 25/36] Remove Tx transition indexer tests --- test/OuraFilters/Auction.hs | 96 +------------------------------------ 1 file changed, 1 insertion(+), 95 deletions(-) diff --git a/test/OuraFilters/Auction.hs b/test/OuraFilters/Auction.hs index 399e2ed..1e2266f 100644 --- a/test/OuraFilters/Auction.hs +++ b/test/OuraFilters/Auction.hs @@ -29,9 +29,7 @@ import Prelude spec :: SpecM (SpotGarbage IO ProcessHandle) () spec = - -- describe "Auction example" do - -- @(SpotGarbage IO ProcessHandle) focus $ it "Catches any Auction validator transition" \spotGarbage -> let auctionPaymentCredential = @@ -73,100 +71,8 @@ spec = <$> oura.receive (txEvent ^. Mock.parsed_tx . Mock.hash) `shouldBe` rightTxHash oura.shutDown - it "Recognizes 'Create' transition" \spotGarbage -> - let - params = - Auction.MkAuctionParams - { seller = "ab0baab0baab0baab0baab0baab0ba00000000000004444444444444" - , lot = - V1.Value.assetClassValue - ( V1.Value.assetClass - "eeeeeeeeeeffffffffaaaaaaa4444444444444444444444444444444" - "" - ) - 4 - } - rightTxHash = - Mock.MkBlake2b255Hex - "2266778888888888888888888888888888888888888888888888444444444444" - tx = - Mock.txToBS $ - Mock.mkTxEvent $ - Mock.hash .~ rightTxHash $ - createTxMock params - unmatchingTx = Mock.txToBS $ Mock.mkTxEvent Mock.arbitraryTx - in - Oura.withOura (Oura.MkWorkDir "./tmp") spotGarbage makeConfig \oura -> do - withTimeout 3.0 do - oura.send unmatchingTx - oura.send tx - Right txEvent <- - Aeson.eitherDecodeStrict @Mock.TxEvent - <$> oura.receive - (txEvent ^. Mock.parsed_tx . Mock.hash) `shouldBe` rightTxHash + Mock.MkBlake2b255Hex txHash `shouldBe` rightTxHash oura.shutDown - it "Recognizes 'Start' transition" \spotGarbage -> do - fail @IO @() "Not implemented" - it "Recognizes 'MakeBid' transition" \spotGarbage -> do - fail @IO @() "Not implemented" - it "Recognizes 'Close' transition" \spotGarbage -> do - fail @IO @() "Not implemented" - it "Recognizes 'Buyout' transition" \spotGarbage -> do - fail @IO @() "Not implemented" - -createTxMock :: Auction.SimpleAuctionParams -> Mock.Tx -createTxMock params = - Mock.arbitraryTx - & Mock.inputs %~ (:) input - & Mock.outputs %~ (:) output - where - input = - emptyInputFixture - (PlutusLedgerApi.V1.PubKeyCredential params.seller) - Nothing - & Mock.as_output . Mock.assets .~ valueToMultiAsset params.lot - & Mock.redeemer - ?~ Mock.MkRedeemer - { _purpose = Mock.PURPOSE_SPEND - , datum = - Mock.encodePlutusData $ - PlutusLedgerApi.V1.toData Auction.Create - } - - output = - Mock.MkTxOutput - { Mock._address = - Mock.plutusAddressToOuraAddress $ - PlutusLedgerApi.V1.Address - (PlutusLedgerApi.V1.PubKeyCredential params.seller) - Nothing - , Mock._datum = - Just $ - Mock.encodePlutusData $ - PlutusLedgerApi.V1.toData outputState - , Mock._coin = 2 - , Mock._script = Nothing - , Mock._assets = valueToMultiAsset params.lot - } - - outputState :: CEMScriptDatum Auction.SimpleAuction - outputState = (Auction.NoControl, params, Auction.NotStarted) - -valueToMultiAsset :: PlutusLedgerApi.V1.Value -> [Mock.Multiasset] -valueToMultiAsset = - PlutusLedgerApi.V1.getValue >>> AssocMap.toList >>> fmap \(cs, tokens) -> - Mock.MkMultiasset - { Mock._policy_id = Mock.serialiseCurrencySymbol cs - , Mock.assets = - AssocMap.toList tokens <&> \(tn, amt) -> - Mock.MkAsset - { Mock._name = - Mock.serialiseAsHex $ - PlutusLedgerApi.V1.unTokenName tn - , Mock._output_coin = amt -- positive - , Mock._mint_coin = 1 - } - } emptyInputFixture :: PlutusLedgerApi.V1.Credential -> From deed8b7e64b3c4d0b2444aad34a9af9fca208a24 Mon Sep 17 00:00:00 2001 From: Renegatto Date: Mon, 16 Sep 2024 16:49:38 +0300 Subject: [PATCH 26/36] Separate conversion between plutus and cardano from serialization --- test/OuraFilters/Mock.hs | 48 +++++++++++++++++++++++++--------------- 1 file changed, 30 insertions(+), 18 deletions(-) diff --git a/test/OuraFilters/Mock.hs b/test/OuraFilters/Mock.hs index bb1bb4e..56d1727 100644 --- a/test/OuraFilters/Mock.hs +++ b/test/OuraFilters/Mock.hs @@ -6,6 +6,7 @@ module OuraFilters.Mock where +import Cardano.Api qualified import Cardano.Api.Address qualified as Address import Cardano.Api.Ledger qualified import Cardano.Api.Ledger qualified as Cred @@ -27,7 +28,6 @@ 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.Maybe (fromMaybe) import Data.Text qualified as T import Data.Vector qualified as Vec import GHC.Generics (Generic (Rep)) @@ -56,7 +56,7 @@ instance 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 T.Text +newtype Address = MkAddressAsBase64 {_addressL :: T.Text} deriving newtype (Show, Eq, Ord, Aeson.ToJSON, Aeson.FromJSON) makeLenses ''Address @@ -357,22 +357,21 @@ serialiseAsHex = . Base16.encodeBase16 . PlutusLedgerApi.V1.fromBuiltin -plutusAddressToOuraAddress :: (HasCallStack) => PlutusLedgerApi.V1.Address -> Address -plutusAddressToOuraAddress (PlutusLedgerApi.V1.Address payment stake) = - MkAddressAsBase64 - . Base64.extractBase64 - . Base64.encodeBase64 - . SerialiseRaw.serialiseToRawBytes - $ Address.ShelleyAddress - Ledger.Mainnet - ( fromMaybe - (error "plutusAaddressToOuraAddress:can't decode payment credential") - paymentCredential - ) - ( fromMaybe - (error "plutusAaddressToOuraAddress:can't decode stake credential") - stakeCredential - ) +plutusAddressToShelleyAddress :: + PlutusLedgerApi.V1.Address -> + Either String (Cardano.Api.Address Cardano.Api.ShelleyAddr) +plutusAddressToShelleyAddress (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 $ Address.ShelleyAddress Ledger.Mainnet paymentCred stakeCred where credentialToCardano ( PlutusLedgerApi.V1.PubKeyCredential @@ -405,3 +404,16 @@ plutusAddressToOuraAddress (PlutusLedgerApi.V1.Address payment stake) = (Ledger.SlotNo $ fromInteger slotNo) (Ledger.TxIx $ fromInteger txIx) (Ledger.CertIx $ fromInteger sertId) + +shelleyAddressBech32 :: + Cardano.Api.Address Cardano.Api.ShelleyAddr -> T.Text +shelleyAddressBech32 = Cardano.Api.serialiseToBech32 + +plutusAddressToOuraAddress :: (HasCallStack) => PlutusLedgerApi.V1.Address -> Address +plutusAddressToOuraAddress = + MkAddressAsBase64 + . Base64.extractBase64 + . Base64.encodeBase64 + . SerialiseRaw.serialiseToRawBytes + . either error id + . plutusAddressToShelleyAddress From fdcb9c9a5b075b899ccbbe0213a00e4206504e16 Mon Sep 17 00:00:00 2001 From: Renegatto Date: Mon, 16 Sep 2024 16:50:23 +0300 Subject: [PATCH 27/36] Make extra prisms for oura configs --- test/Oura/Config.hs | 19 +++++++++++++++---- 1 file changed, 15 insertions(+), 4 deletions(-) diff --git a/test/Oura/Config.hs b/test/Oura/Config.hs index 91fdcf6..3087ca8 100644 --- a/test/Oura/Config.hs +++ b/test/Oura/Config.hs @@ -5,6 +5,7 @@ module Oura.Config ( SourcePath (MkSourcePath, unSourcePath), SinkPath (MkSinkPath, unSinkPath), filtersL, + predicateL, tableL, atKey, _Table, @@ -18,9 +19,11 @@ import Prelude import Control.Lens ( At (at), Each (each), + Iso', Lens', Prism', Traversal', + from, iso, mapping, partsOf, @@ -95,13 +98,21 @@ source (MkSourcePath socketPath) = , "type" .= Toml.Text "TxOverSocket" ] -filtersL :: Traversal' Toml.Value [Toml.Table] +newtype Filter = MkFilter {unFilter :: Toml.Table} + deriving newtype (Eq, Show) + +filterL :: Iso' Filter Toml.Table +filterL = iso unFilter MkFilter + +predicateL :: Traversal' Filter T.Text +predicateL = filterL . atKey "predicate" . _Just . _Text + +filtersL :: Traversal' Toml.Table [Filter] filtersL = - _Table - . atKey "filters" + atKey "filters" . _Just . _List - . partsOf (each . _Table) + . partsOf (each . _Table . from filterL) atKey :: T.Text -> Traversal' Toml.Table (Maybe Toml.Value) atKey key = tableL . at key From b203fbcdae4c378c5cd230858d9ba53e80273d3e Mon Sep 17 00:00:00 2001 From: Renegatto Date: Mon, 16 Sep 2024 16:51:40 +0300 Subject: [PATCH 28/36] Make test work with matching stake credntial --- test/OuraFilters.hs | 3 +- test/OuraFilters/Auction.hs | 70 ++++++++++++++++++++++++------------- 2 files changed, 47 insertions(+), 26 deletions(-) diff --git a/test/OuraFilters.hs b/test/OuraFilters.hs index bb302a0..e0b99fd 100644 --- a/test/OuraFilters.hs +++ b/test/OuraFilters.hs @@ -13,6 +13,7 @@ import Data.Function ((&)) import Data.Text qualified as T import Oura (Oura (receive, send, shutDown)) import Oura qualified +import Oura.Config qualified as Config import OuraFilters.Auction qualified import OuraFilters.Mock qualified as Mock import PlutusLedgerApi.V1 qualified as V1 @@ -76,7 +77,7 @@ ouraFiltersSpec = Utils.killProcessesOnError do tx = Mock.txToBS exampleTx matchingTx = Mock.txToBS exampleMatchingTx in - Oura.withOura (Oura.MkWorkDir "./tmp") spotGarbage undefined \oura -> do + Oura.withOura (Oura.MkWorkDir "./tmp") spotGarbage Config.daemonConfig \oura -> do Utils.withTimeout 3.0 do oura.send tx oura.send matchingTx diff --git a/test/OuraFilters/Auction.hs b/test/OuraFilters/Auction.hs index 1e2266f..99c883d 100644 --- a/test/OuraFilters/Auction.hs +++ b/test/OuraFilters/Auction.hs @@ -3,23 +3,25 @@ module OuraFilters.Auction (spec) where -import Cardano.CEM (CEMScriptDatum) import Cardano.CEM.Examples.Auction qualified as Auction import Cardano.CEM.Examples.Compilation () import Cardano.CEM.OnChain qualified as Compiled -import Control.Arrow ((>>>)) -import Control.Lens ((%~), (.~), (?~), (^.)) +import Control.Lens (Ixed (ix), (%~), (.~)) +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.Function ((&)) -import Data.Functor ((<&>)) +import Data.Text qualified as T +import Data.Text.IO qualified as T.IO import Oura qualified import Oura.Config qualified as Config import OuraFilters.Mock qualified as Mock import Plutus.Extras (scriptValidatorHash) import PlutusLedgerApi.V1 qualified -import PlutusLedgerApi.V1.Value qualified as V1.Value -import PlutusTx.AssocMap qualified as AssocMap import System.Process (ProcessHandle) import Test.Hspec (describe, focus, it, shouldBe) import Test.Hspec.Core.Spec (SpecM) @@ -32,27 +34,35 @@ spec = describe "Auction example" do focus $ it "Catches any Auction validator transition" \spotGarbage -> let + auctionAddress = + PlutusLedgerApi.V1.Address + auctionPaymentCredential + Nothing + auctionAddressBech32Text = + Mock.shelleyAddressBech32 + . either error id + $ Mock.plutusAddressToShelleyAddress auctionAddress auctionPaymentCredential = - PlutusLedgerApi.V1.ScriptCredential - . scriptValidatorHash + 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 - auctionOuraFilters = error "Not implemented" - defaultTx = Mock.arbitraryTx + rightTxHash = Mock.MkBlake2b255Hex "2266778888888888888888888888888888888888888888888888444444444444" inputFromValidator = - emptyInputFixture auctionPaymentCredential (Just arbitraryStakeCredential) - + emptyInputFixture auctionPaymentCredential Nothing -- (Just arbitraryStakeCredential) tx = Mock.txToBS . Mock.mkTxEvent . (Mock.inputs %~ (inputFromValidator :)) . (Mock.hash .~ rightTxHash) - $ defaultTx + $ Mock.arbitraryTx unmatchingTx = Mock.txToBS . Mock.mkTxEvent @@ -60,19 +70,23 @@ spec = makeConfig :: Config.SourcePath -> Config.SinkPath -> Toml.Table makeConfig sourcePath sinkPath = Config.daemonConfig sourcePath sinkPath - & Config.filtersL .~ auctionOuraFilters + & Config.filtersL + . ix 0 + . Config.predicateL + .~ auctionAddressBech32Text in - Oura.withOura (Oura.MkWorkDir "./tmp") spotGarbage makeConfig \oura -> do - withTimeout 3.0 do - oura.send unmatchingTx - oura.send tx - Right txEvent <- - Aeson.eitherDecodeStrict @Mock.TxEvent - <$> oura.receive - (txEvent ^. Mock.parsed_tx . Mock.hash) `shouldBe` rightTxHash - oura.shutDown - Mock.MkBlake2b255Hex txHash `shouldBe` rightTxHash - oura.shutDown + do + putStrLn "Hash:" + T.IO.putStrLn auctionAddressBech32Text + Oura.withOura (Oura.MkWorkDir "./tmp") spotGarbage makeConfig \oura -> do + withTimeout 6.0 do + oura.send unmatchingTx + oura.send tx + msg <- oura.receive + BS.IO.putStrLn $ "message: " <> msg + txHash <- either error pure $ extractTxHash msg + Mock.MkBlake2b255Hex txHash `shouldBe` rightTxHash + oura.shutDown emptyInputFixture :: PlutusLedgerApi.V1.Credential -> @@ -94,3 +108,9 @@ emptyInputFixture paymentCred mstakeCred = , 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" From 2464e77e0d70603b0b6bf5b32934e210e12f2044 Mon Sep 17 00:00:00 2001 From: Renegatto Date: Mon, 16 Sep 2024 17:16:42 +0300 Subject: [PATCH 29/36] Implement OuraConfig generator --- cem-script.cabal | 2 + src/Cardano/CEM/OuraConfig.hs | 77 +++++++++++++++++++++++++++++++++++ 2 files changed, 79 insertions(+) create mode 100644 src/Cardano/CEM/OuraConfig.hs diff --git a/cem-script.cabal b/cem-script.cabal index 7a6adfa..ceead04 100644 --- a/cem-script.cabal +++ b/cem-script.cabal @@ -147,6 +147,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 +159,7 @@ library , cem-script:cardano-extras , cem-script:data-spine , clb + , toml-parser , dependent-map , ouroboros-consensus , QuickCheck diff --git a/src/Cardano/CEM/OuraConfig.hs b/src/Cardano/CEM/OuraConfig.hs new file mode 100644 index 0000000..9b13be7 --- /dev/null +++ b/src/Cardano/CEM/OuraConfig.hs @@ -0,0 +1,77 @@ +module Cardano.CEM.OuraConfig + ( SourcePath (MkSourcePath, unSourcePath) + , SinkPath (MkSinkPath, unSinkPath) + , Filter (MkFilter, unFilter) + , daemonConfig + , selectByAddress + ) where +import Toml qualified +import Data.Text qualified as T +import Data.String (IsString) +import Prelude +import Toml.Schema.ToValue qualified as Toml.ToValue +import Toml.Schema ((.=)) + +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 :: SourcePath -> SinkPath -> [Filter] -> Toml.Table +daemonConfig sourcePath sinkPath filters = + 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 :: T.Text -> Filter +selectByAddress addressBech32 = + MkFilter $ Toml.ToValue.table + [ "predicate" .= Toml.Text addressBech32 -- "addr1qx2fxv2umyhttkxyxp8x0dlpdt3k6cwng5pxj3jhsydzer3n0d3vllmyqwsx5wktcd8cc3sq835lu7drv2xwl2wywfgse35a3x" + , "skip_uncertain" .= Toml.Bool False + , "type" .= Toml.Text "Select" + ] + +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" + ] \ No newline at end of file From 8928b4f1c945ff2808c83ad0384e7c3fd52e4e11 Mon Sep 17 00:00:00 2001 From: Renegatto Date: Mon, 16 Sep 2024 17:17:48 +0300 Subject: [PATCH 30/36] Move OuraConfig gen out from tests --- src/Cardano/CEM/OuraConfig.hs | 4 +- test/Oura.hs | 2 +- test/Oura/Communication.hs | 2 +- test/Oura/Config.hs | 77 +++-------------------------------- test/OuraFilters.hs | 30 +++++++++----- test/OuraFilters/Auction.hs | 19 +++++---- 6 files changed, 38 insertions(+), 96 deletions(-) diff --git a/src/Cardano/CEM/OuraConfig.hs b/src/Cardano/CEM/OuraConfig.hs index 9b13be7..079b1c3 100644 --- a/src/Cardano/CEM/OuraConfig.hs +++ b/src/Cardano/CEM/OuraConfig.hs @@ -21,8 +21,8 @@ newtype SinkPath = MkSinkPath {unSinkPath :: T.Text} newtype Filter = MkFilter {unFilter :: Toml.Table} deriving newtype (Eq, Show) -daemonConfig :: SourcePath -> SinkPath -> [Filter] -> Toml.Table -daemonConfig sourcePath sinkPath filters = +daemonConfig :: [Filter] -> SourcePath -> SinkPath -> Toml.Table +daemonConfig filters sourcePath sinkPath = Toml.ToValue.table [ "filters" .= Toml.List (Toml.Table . unFilter <$> filters) , "cursor" .= cursor diff --git a/test/Oura.hs b/test/Oura.hs index 9cdcd04..25e534c 100644 --- a/test/Oura.hs +++ b/test/Oura.hs @@ -22,11 +22,11 @@ import Toml.Pretty qualified import Utils (withNewFile) import Utils qualified +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 Oura.Config qualified as Config import System.Directory (removeFile) import Toml (Table) diff --git a/test/Oura/Communication.hs b/test/Oura/Communication.hs index af3d384..f71110e 100644 --- a/test/Oura/Communication.hs +++ b/test/Oura/Communication.hs @@ -31,8 +31,8 @@ import Data.Traversable (for) import Network.Socket qualified as Socket import Network.Socket.ByteString qualified as Socket.BS +import Cardano.CEM.OuraConfig (SinkPath, SourcePath (MkSourcePath), unSinkPath) import Data.ByteString.Char8 qualified as BS.Char8 -import Oura.Config (SinkPath, SourcePath (MkSourcePath), unSinkPath) data OuraDaemonConnection = MkOuraDaemonConnection { ownSocket :: Socket.Socket diff --git a/test/Oura/Config.hs b/test/Oura/Config.hs index 3087ca8..513d493 100644 --- a/test/Oura/Config.hs +++ b/test/Oura/Config.hs @@ -1,9 +1,6 @@ {-# LANGUAGE BlockArguments #-} module Oura.Config ( - daemonConfig, - SourcePath (MkSourcePath, unSourcePath), - SinkPath (MkSinkPath, unSinkPath), filtersL, predicateL, tableL, @@ -16,6 +13,7 @@ module Oura.Config ( import Prelude +import Cardano.CEM.OuraConfig qualified as Config import Control.Lens ( At (at), Each (each), @@ -31,83 +29,18 @@ import Control.Lens ( _Just, ) import Data.Map (Map) -import Data.String (IsString) 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 -newtype SinkPath = MkSinkPath {unSinkPath :: T.Text} - deriving newtype (IsString) - -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 - ] - -filters :: [Toml.Value] -filters = - [ Toml.Table $ - Toml.ToValue.table - [ "predicate" .= Toml.Text "addr1qx2fxv2umyhttkxyxp8x0dlpdt3k6cwng5pxj3jhsydzer3n0d3vllmyqwsx5wktcd8cc3sq835lu7drv2xwl2wywfgse35a3x" - , "skip_uncertain" .= Toml.Bool False - , "type" .= Toml.Text "Select" - ] - ] - -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" - ] - -newtype Filter = MkFilter {unFilter :: Toml.Table} - deriving newtype (Eq, Show) - -filterL :: Iso' Filter Toml.Table -filterL = iso unFilter MkFilter - -predicateL :: Traversal' Filter T.Text +predicateL :: Traversal' Config.Filter T.Text predicateL = filterL . atKey "predicate" . _Just . _Text -filtersL :: Traversal' Toml.Table [Filter] +filtersL :: Traversal' Toml.Table [Config.Filter] filtersL = atKey "filters" . _Just diff --git a/test/OuraFilters.hs b/test/OuraFilters.hs index e0b99fd..b199c4c 100644 --- a/test/OuraFilters.hs +++ b/test/OuraFilters.hs @@ -1,8 +1,10 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} module OuraFilters (ouraFiltersSpec) where +import Cardano.CEM.OuraConfig qualified as Config import Control.Lens (ix, (.~)) import Control.Monad ((>=>)) import Data.Aeson ((.:)) @@ -13,7 +15,6 @@ import Data.Function ((&)) import Data.Text qualified as T import Oura (Oura (receive, send, shutDown)) import Oura qualified -import Oura.Config qualified as Config import OuraFilters.Auction qualified import OuraFilters.Mock qualified as Mock import PlutusLedgerApi.V1 qualified as V1 @@ -28,6 +29,9 @@ exampleMatchingTx = where inputAddress = Mock.MkAddressAsBase64 "AZSTMVzZLrXYxDBOZ7fhauNtYdNFAmlGV4EaLI4ze2LP/2QDoGo6y8NPjEYAPGn+eaNijO+pxHJR" +exampleFilter :: Config.Filter +exampleFilter = Config.selectByAddress "addr1qx2fxv2umyhttkxyxp8x0dlpdt3k6cwng5pxj3jhsydzer3n0d3vllmyqwsx5wktcd8cc3sq835lu7drv2xwl2wywfgse35a3x" + exampleTx :: Mock.TxEvent exampleTx = Mock.mkTxEvent $ @@ -77,16 +81,20 @@ ouraFiltersSpec = Utils.killProcessesOnError do tx = Mock.txToBS exampleTx matchingTx = Mock.txToBS exampleMatchingTx in - Oura.withOura (Oura.MkWorkDir "./tmp") spotGarbage Config.daemonConfig \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 + 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 diff --git a/test/OuraFilters/Auction.hs b/test/OuraFilters/Auction.hs index 99c883d..63f9972 100644 --- a/test/OuraFilters/Auction.hs +++ b/test/OuraFilters/Auction.hs @@ -6,7 +6,7 @@ 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 Control.Lens (Ixed (ix), (%~), (.~)) +import Control.Lens ((%~), (.~)) import Control.Monad ((>=>)) import Data.Aeson ((.:)) import Data.Aeson qualified as Aeson @@ -14,11 +14,13 @@ 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.Function ((&)) import Data.Text qualified as T import Data.Text.IO qualified as T.IO import Oura qualified -import Oura.Config qualified as Config + +-- import Oura.Config qualified as Config + +import Cardano.CEM.OuraConfig qualified as OuraConfig import OuraFilters.Mock qualified as Mock import Plutus.Extras (scriptValidatorHash) import PlutusLedgerApi.V1 qualified @@ -67,13 +69,12 @@ spec = Mock.txToBS . Mock.mkTxEvent $ Mock.arbitraryTx - makeConfig :: Config.SourcePath -> Config.SinkPath -> Toml.Table + makeConfig :: OuraConfig.SourcePath -> OuraConfig.SinkPath -> Toml.Table makeConfig sourcePath sinkPath = - Config.daemonConfig sourcePath sinkPath - & Config.filtersL - . ix 0 - . Config.predicateL - .~ auctionAddressBech32Text + OuraConfig.daemonConfig + [OuraConfig.selectByAddress auctionAddressBech32Text] + sourcePath + sinkPath in do putStrLn "Hash:" From 5e7484e94f544fa8375f63922e37dca067405c25 Mon Sep 17 00:00:00 2001 From: Renegatto Date: Mon, 16 Sep 2024 19:02:15 +0300 Subject: [PATCH 31/36] Update oura to obtain a bugfix for filtering by payment key --- flake.lock | 8 ++++---- flake.nix | 2 +- 2 files changed, 5 insertions(+), 5 deletions(-) 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"; From 58f37bc3124bba55e7985aeaccd50e3483da47a6 Mon Sep 17 00:00:00 2001 From: Renegatto Date: Mon, 16 Sep 2024 19:45:24 +0300 Subject: [PATCH 32/36] Format code --- src/Cardano/CEM/OuraConfig.hs | 36 ++++++++++++++++++----------------- 1 file changed, 19 insertions(+), 17 deletions(-) diff --git a/src/Cardano/CEM/OuraConfig.hs b/src/Cardano/CEM/OuraConfig.hs index 079b1c3..90a9d0e 100644 --- a/src/Cardano/CEM/OuraConfig.hs +++ b/src/Cardano/CEM/OuraConfig.hs @@ -1,16 +1,17 @@ -module Cardano.CEM.OuraConfig - ( SourcePath (MkSourcePath, unSourcePath) - , SinkPath (MkSinkPath, unSinkPath) - , Filter (MkFilter, unFilter) - , daemonConfig - , selectByAddress - ) where -import Toml qualified -import Data.Text qualified as T +module Cardano.CEM.OuraConfig ( + SourcePath (MkSourcePath, unSourcePath), + SinkPath (MkSinkPath, unSinkPath), + Filter (MkFilter, unFilter), + daemonConfig, + selectByAddress, +) where + import Data.String (IsString) -import Prelude -import Toml.Schema.ToValue qualified as Toml.ToValue +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) @@ -34,11 +35,12 @@ daemonConfig filters sourcePath sinkPath = -- | A oura *filter* that selects by address selectByAddress :: T.Text -> Filter selectByAddress addressBech32 = - MkFilter $ Toml.ToValue.table - [ "predicate" .= Toml.Text addressBech32 -- "addr1qx2fxv2umyhttkxyxp8x0dlpdt3k6cwng5pxj3jhsydzer3n0d3vllmyqwsx5wktcd8cc3sq835lu7drv2xwl2wywfgse35a3x" - , "skip_uncertain" .= Toml.Bool False - , "type" .= Toml.Text "Select" - ] + MkFilter $ + Toml.ToValue.table + [ "predicate" .= Toml.Text addressBech32 -- "addr1qx2fxv2umyhttkxyxp8x0dlpdt3k6cwng5pxj3jhsydzer3n0d3vllmyqwsx5wktcd8cc3sq835lu7drv2xwl2wywfgse35a3x" + , "skip_uncertain" .= Toml.Bool False + , "type" .= Toml.Text "Select" + ] cursor :: Toml.Table cursor = @@ -74,4 +76,4 @@ source (MkSourcePath socketPath) = Toml.ToValue.table [ "socket_path" .= Toml.Text socketPath , "type" .= Toml.Text "TxOverSocket" - ] \ No newline at end of file + ] From 2e80272355991c6edde3c136ee361a1d74c48e29 Mon Sep 17 00:00:00 2001 From: Renegatto Date: Mon, 16 Sep 2024 19:46:26 +0300 Subject: [PATCH 33/36] Adopt new oura --- test/OuraFilters.hs | 25 +++++++++++++++---------- test/OuraFilters/Mock.hs | 15 +++++++++++++-- 2 files changed, 28 insertions(+), 12 deletions(-) diff --git a/test/OuraFilters.hs b/test/OuraFilters.hs index b199c4c..8cc43e7 100644 --- a/test/OuraFilters.hs +++ b/test/OuraFilters.hs @@ -45,7 +45,7 @@ exampleTx = Just $ Mock.MkRedeemer { _purpose = Mock.PURPOSE_UNSPECIFIED - , datum = Mock.encodePlutusData (V1.I 212) + , payload = Mock.encodePlutusData (V1.I 212) } } ] @@ -62,15 +62,20 @@ exampleTx = , Mock._assets = [] , Mock._datum = Just $ - 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.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 } diff --git a/test/OuraFilters/Mock.hs b/test/OuraFilters/Mock.hs index 56d1727..cc9e41c 100644 --- a/test/OuraFilters/Mock.hs +++ b/test/OuraFilters/Mock.hs @@ -120,9 +120,20 @@ instance Aeson.FromJSON Purpose where 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 - , datum :: PlutusData + , payload :: PlutusData } deriving stock (Generic) deriving (Aeson.ToJSON) via (WithoutUnderscore Redeemer) @@ -133,7 +144,7 @@ data TxOutput = MkTxOutput { _address :: Address , _coin :: Integer , _assets :: [Multiasset] - , _datum :: Maybe PlutusData + , _datum :: Maybe Datum , _script :: Maybe Aeson.Value } deriving stock (Generic) From e4ab8a8f15b8f4c584f6fb278db9a585cc744cca Mon Sep 17 00:00:00 2001 From: Renegatto Date: Mon, 16 Sep 2024 19:46:55 +0300 Subject: [PATCH 34/36] Test that indexer ignores staking credential --- test/OuraFilters/Auction.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/OuraFilters/Auction.hs b/test/OuraFilters/Auction.hs index 63f9972..0327ecc 100644 --- a/test/OuraFilters/Auction.hs +++ b/test/OuraFilters/Auction.hs @@ -58,7 +58,7 @@ spec = Mock.MkBlake2b255Hex "2266778888888888888888888888888888888888888888888888444444444444" inputFromValidator = - emptyInputFixture auctionPaymentCredential Nothing -- (Just arbitraryStakeCredential) + emptyInputFixture auctionPaymentCredential (Just arbitraryStakeCredential) tx = Mock.txToBS . Mock.mkTxEvent From 02f28fbc3c54ea2e16efeff53e026a955557bd0f Mon Sep 17 00:00:00 2001 From: Renegatto Date: Mon, 16 Sep 2024 19:47:12 +0300 Subject: [PATCH 35/36] Resolve nix develop error --- oura.nix | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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; }; From ae302686587b5529de4ccbbe6d10f4afe18058df Mon Sep 17 00:00:00 2001 From: Renegatto Date: Mon, 16 Sep 2024 21:18:18 +0300 Subject: [PATCH 36/36] Move CEMScript to oura config functionality in CEM.OuraConfig --- cem-script.cabal | 1 + src/Cardano/CEM/Address.hs | 91 +++++++++++++++++++++++++++++++++++ src/Cardano/CEM/OuraConfig.hs | 25 +++++++++- test/OuraFilters/Auction.hs | 48 +++++++----------- test/OuraFilters/Mock.hs | 63 +----------------------- 5 files changed, 134 insertions(+), 94 deletions(-) create mode 100644 src/Cardano/CEM/Address.hs diff --git a/cem-script.cabal b/cem-script.cabal index ceead04..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 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/OuraConfig.hs b/src/Cardano/CEM/OuraConfig.hs index 90a9d0e..04a0f81 100644 --- a/src/Cardano/CEM/OuraConfig.hs +++ b/src/Cardano/CEM/OuraConfig.hs @@ -4,8 +4,13 @@ module Cardano.CEM.OuraConfig ( 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 @@ -33,8 +38,8 @@ daemonConfig filters sourcePath sinkPath = ] -- | A oura *filter* that selects by address -selectByAddress :: T.Text -> Filter -selectByAddress addressBech32 = +selectByAddress :: Address.AddressBech32 -> Filter +selectByAddress (Address.MkAddressBech32 addressBech32) = MkFilter $ Toml.ToValue.table [ "predicate" .= Toml.Text addressBech32 -- "addr1qx2fxv2umyhttkxyxp8x0dlpdt3k6cwng5pxj3jhsydzer3n0d3vllmyqwsx5wktcd8cc3sq835lu7drv2xwl2wywfgse35a3x" @@ -42,6 +47,22 @@ selectByAddress addressBech32 = , "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 diff --git a/test/OuraFilters/Auction.hs b/test/OuraFilters/Auction.hs index 0327ecc..610bea9 100644 --- a/test/OuraFilters/Auction.hs +++ b/test/OuraFilters/Auction.hs @@ -6,6 +6,8 @@ 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 ((.:)) @@ -15,19 +17,13 @@ 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 Data.Text.IO qualified as T.IO import Oura qualified - --- import Oura.Config qualified as Config - -import Cardano.CEM.OuraConfig qualified as OuraConfig 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 Toml qualified import Utils (SpotGarbage, withTimeout) import Prelude @@ -36,14 +32,6 @@ spec = describe "Auction example" do focus $ it "Catches any Auction validator transition" \spotGarbage -> let - auctionAddress = - PlutusLedgerApi.V1.Address - auctionPaymentCredential - Nothing - auctionAddressBech32Text = - Mock.shelleyAddressBech32 - . either error id - $ Mock.plutusAddressToShelleyAddress auctionAddress auctionPaymentCredential = PlutusLedgerApi.V1.ScriptCredential auctionValidatorHash auctionValidatorHash = @@ -69,25 +57,23 @@ spec = Mock.txToBS . Mock.mkTxEvent $ Mock.arbitraryTx - makeConfig :: OuraConfig.SourcePath -> OuraConfig.SinkPath -> Toml.Table - makeConfig sourcePath sinkPath = - OuraConfig.daemonConfig - [OuraConfig.selectByAddress auctionAddressBech32Text] - sourcePath - sinkPath + makeConfig source sink = + either error id $ + OuraConfig.ouraMonitoringScript (Proxy @Auction.SimpleAuction) Ledger.Mainnet source sink in do - putStrLn "Hash:" - T.IO.putStrLn auctionAddressBech32Text - Oura.withOura (Oura.MkWorkDir "./tmp") spotGarbage makeConfig \oura -> do - withTimeout 6.0 do - oura.send unmatchingTx - oura.send tx - msg <- oura.receive - BS.IO.putStrLn $ "message: " <> msg - txHash <- either error pure $ extractTxHash msg - Mock.MkBlake2b255Hex txHash `shouldBe` rightTxHash - oura.shutDown + 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 -> diff --git a/test/OuraFilters/Mock.hs b/test/OuraFilters/Mock.hs index cc9e41c..a05c8e6 100644 --- a/test/OuraFilters/Mock.hs +++ b/test/OuraFilters/Mock.hs @@ -6,16 +6,9 @@ module OuraFilters.Mock where -import Cardano.Api qualified -import Cardano.Api.Address qualified as Address -import Cardano.Api.Ledger qualified -import Cardano.Api.Ledger qualified as Cred import Cardano.Api.SerialiseRaw qualified as SerialiseRaw -import Cardano.Crypto.Hash qualified as Cardano.Hash +import Cardano.CEM.Address qualified as Address 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 Control.Lens.TH (makeLenses, makeLensesFor) import Control.Monad ((<=<)) import Data.Aeson (KeyValue ((.=))) @@ -368,58 +361,6 @@ serialiseAsHex = . Base16.encodeBase16 . PlutusLedgerApi.V1.fromBuiltin -plutusAddressToShelleyAddress :: - PlutusLedgerApi.V1.Address -> - Either String (Cardano.Api.Address Cardano.Api.ShelleyAddr) -plutusAddressToShelleyAddress (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 $ Address.ShelleyAddress Ledger.Mainnet 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) - -shelleyAddressBech32 :: - Cardano.Api.Address Cardano.Api.ShelleyAddr -> T.Text -shelleyAddressBech32 = Cardano.Api.serialiseToBech32 - plutusAddressToOuraAddress :: (HasCallStack) => PlutusLedgerApi.V1.Address -> Address plutusAddressToOuraAddress = MkAddressAsBase64 @@ -427,4 +368,4 @@ plutusAddressToOuraAddress = . Base64.encodeBase64 . SerialiseRaw.serialiseToRawBytes . either error id - . plutusAddressToShelleyAddress + . Address.plutusAddressToShelleyAddress Ledger.Mainnet