From 7e39ee5cbb8b512f873de05af3573bda1355d0aa Mon Sep 17 00:00:00 2001 From: Gregory Gerasev Date: Mon, 1 Jul 2024 06:59:39 +0700 Subject: [PATCH] Add structured logs interface and script fees recording Also updates CLB dep --- cabal.project | 4 +-- src/Cardano/CEM/Monads.hs | 23 ++++++++++++- src/Cardano/CEM/Monads/CLB.hs | 44 ++++++++++++++++++------- src/Cardano/CEM/Monads/L1.hs | 4 +++ src/Cardano/CEM/Monads/L1Commons.hs | 37 +++++++++++++++++++++ src/Cardano/CEM/OffChain.hs | 13 +++++--- src/Cardano/CEM/Testing/StateMachine.hs | 8 ++--- test/Utils.hs | 35 ++++++++++++++++---- test/Voting.hs | 2 +- 9 files changed, 139 insertions(+), 31 deletions(-) diff --git a/cabal.project b/cabal.project index 343ade2..0fff610 100644 --- a/cabal.project +++ b/cabal.project @@ -19,10 +19,10 @@ tests: true source-repository-package type: git location: https://github.com/mlabs-haskell/clb - tag: 925f80a9755d2292edf4589afb50dc1146b36ac2 + tag: d5b0e7ce07258482d53704ce19383013b1fa6610 --sha256: 6+Os/mQDzBOU+TkTD+n/T1MFcI+Mn0/tcBMJhLRfqyA= --- Cannot use new commit, because it requires `plutus-ledger-api==1.29` +-- FIXME: Cannot use new commit, because it requires `plutus-ledger-api==1.29` source-repository-package type: git location: https://github.com/Plutonomicon/plutarch-plutus diff --git a/src/Cardano/CEM/Monads.hs b/src/Cardano/CEM/Monads.hs index a47fde8..301da94 100644 --- a/src/Cardano/CEM/Monads.hs +++ b/src/Cardano/CEM/Monads.hs @@ -60,13 +60,34 @@ data BlockchainParams = MkBlockchainParams } deriving stock (Show) +data Fees = MkFees + { fee :: Coin + , usedMemory :: Natural + , usedCpu :: Natural + } + deriving stock (Show) + +data BlockchainMonadEvent + = SubmittedTxSpec TxSpec (Either TxResolutionError TxId) + | UserSpentFee + { txId :: TxId + , txSigner :: SigningKey PaymentKey + , fees :: Fees + } + | AwaitedTx TxId + deriving stock (Show) + {- | This monad gives access to all information about Cardano params, - | which is various kind of Ledger params and ValidityBound/Slots semantics + which is various kind of Ledger params and ValidityBound/Slots semantics + + Also contains common structured log support. -} class (MonadFail m) => MonadBlockchainParams m where askNetworkId :: m NetworkId queryCurrentSlot :: m SlotNo queryBlockchainParams :: m BlockchainParams + logEvent :: BlockchainMonadEvent -> m () + eventList :: m [BlockchainMonadEvent] -- MonadQuery diff --git a/src/Cardano/CEM/Monads/CLB.hs b/src/Cardano/CEM/Monads/CLB.hs index 8b74b29..0a887ba 100644 --- a/src/Cardano/CEM/Monads/CLB.hs +++ b/src/Cardano/CEM/Monads/CLB.hs @@ -4,6 +4,7 @@ module Cardano.CEM.Monads.CLB where import Prelude +import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar, readMVar) import Control.Monad.State (StateT (..), gets) import Data.Map qualified as Map import Data.Set qualified as Set @@ -34,12 +35,23 @@ import Clb.TimeSlot (posixTimeToUTCTime) import Cardano.CEM.Monads import Cardano.CEM.Monads.L1Commons import Cardano.CEM.OffChain (fromPlutusAddressInMonad) +import Control.Monad.Reader (MonadReader (..), ReaderT (..)) -instance (MonadFail m) => MonadBlockchainParams (ClbT m) where - askNetworkId :: ClbT m NetworkId +instance (MonadReader r m) => MonadReader r (ClbT m) where + ask = lift ask + local f action = ClbT $ local f $ unwrapClbT action + +type ClbRunner = ClbT (ReaderT (MVar [BlockchainMonadEvent]) IO) + +instance + ( MonadFail m + , MonadIO m + , MonadReader (MVar [BlockchainMonadEvent]) m + ) => + MonadBlockchainParams (ClbT m) + where askNetworkId = gets (mockConfigNetworkId . mockConfig) - queryCurrentSlot :: ClbT m SlotNo queryCurrentSlot = getCurrentSlot queryBlockchainParams = do @@ -56,8 +68,14 @@ instance (MonadFail m) => MonadBlockchainParams (ClbT m) where , -- Staking is not supported stakePools = Set.empty } + logEvent e = do + logVar <- ask + liftIO $ modifyMVar_ logVar (return . (:) e) + eventList = do + events <- ask + liftIO $ readMVar events -instance (MonadFail m) => MonadQueryUtxo (ClbT m) where +instance (Monad m, MonadBlockchainParams (ClbT m)) => MonadQueryUtxo (ClbT m) where queryUtxo query = do utxos <- fromLedgerUTxO shelleyBasedEra <$> gets getUtxosAtState predicate <- mkPredicate @@ -69,7 +87,7 @@ instance (MonadFail m) => MonadQueryUtxo (ClbT m) where return $ \_ (TxOut a _ _ _) -> a `elem` cardanoAddresses ByTxIns txIns -> return $ \txIn _ -> txIn `elem` txIns -instance (MonadFail m) => MonadSubmitTx (ClbT m) where +instance (Monad m, MonadBlockchainParams (ClbT m)) => MonadSubmitTx (ClbT m) where submitResolvedTx :: ResolvedTx -> ClbT m (Either TxSubmittingError TxId) submitResolvedTx tx = do cardanoTxBodyFromResolvedTx tx >>= \case @@ -82,16 +100,20 @@ instance (MonadFail m) => MonadSubmitTx (ClbT m) where Right (_, _) -> fail "Unsupported tx format" Left e -> return $ Left $ UnhandledAutobalanceError e -instance (MonadFail m) => MonadTest (ClbT m) where +instance (Monad m, MonadBlockchainParams (ClbT m)) => MonadTest (ClbT m) where getTestWalletSks = return $ map intToCardanoSk [1 .. 10] genesisClbState :: Value -> ClbState genesisClbState genesisValue = initClb defaultBabbage genesisValue genesisValue -execOnIsolatedClb :: Value -> ClbT IO a -> IO a -execOnIsolatedClb genesisValue action = +execOnIsolatedClb :: Value -> ClbRunner a -> IO a +execOnIsolatedClb genesisValue action = do + emptyLog <- newMVar [] fst - <$> runStateT - (unwrapClbT action) - (genesisClbState genesisValue) + <$> runReaderT + ( runStateT + (unwrapClbT action) + (genesisClbState genesisValue) + ) + emptyLog diff --git a/src/Cardano/CEM/Monads/L1.hs b/src/Cardano/CEM/Monads/L1.hs index 8b64db8..998e2d6 100644 --- a/src/Cardano/CEM/Monads/L1.hs +++ b/src/Cardano/CEM/Monads/L1.hs @@ -63,6 +63,10 @@ instance MonadBlockchainParams L1Runner where <*> (toLedgerEpochInfo <$> queryCardanoNode QueryEraHistory) <*> queryCardanoNodeWrapping QueryStakePools + -- FIXME + logEvent _ = return () + eventList = return [] + queryCardanoNodeWrapping :: QueryInShelleyBasedEra Era b -> L1Runner b queryCardanoNodeWrapping query = handleEitherEra =<< queryCardanoNode wrapped diff --git a/src/Cardano/CEM/Monads/L1Commons.hs b/src/Cardano/CEM/Monads/L1Commons.hs index 0369c1f..ff86e98 100644 --- a/src/Cardano/CEM/Monads/L1Commons.hs +++ b/src/Cardano/CEM/Monads/L1Commons.hs @@ -16,6 +16,7 @@ import Cardano.Api.Shelley (LedgerProtocolParameters (..)) import Cardano.CEM.Monads import Cardano.CEM.OffChain import Cardano.Extras +import Data.Maybe (mapMaybe) -- Main function @@ -89,7 +90,43 @@ cardanoTxBodyFromResolvedTx (MkResolvedTx {..}) = do let tx = makeSignedTransactionWithKeys [signer] body txInMode = TxInMode ShelleyBasedEraBabbage tx + + lift $ recordFee txInsUtxo body + return (body, txInMode) + where + recordFee txInsUtxo body@(TxBody content) = do + case txFee content of + TxFeeExplicit era coin -> do + MkBlockchainParams {protocolParameters, systemStart, eraHistory} <- + queryBlockchainParams + Right report <- + return $ + evaluateTransactionExecutionUnits + (shelleyBasedToCardanoEra era) + systemStart + eraHistory + (LedgerProtocolParameters protocolParameters) + txInsUtxo + body + let + rights = mapMaybe $ \case + Right x -> Just x + Left _ -> Nothing + budgets = rights $ map snd $ Map.toList report + usedMemory = sum $ executionMemory <$> budgets + usedCpu = sum $ executionSteps <$> budgets + logEvent $ + UserSpentFee + { fees = + MkFees + { fee = coin + , usedMemory + , usedCpu + } + , txId = getTxId body + , txSigner = signer + } -- Utils diff --git a/src/Cardano/CEM/OffChain.hs b/src/Cardano/CEM/OffChain.hs index 27b4641..c4c5caf 100644 --- a/src/Cardano/CEM/OffChain.hs +++ b/src/Cardano/CEM/OffChain.hs @@ -56,7 +56,7 @@ awaitTx txId = do exists <- checkTxIdExists txId liftIO $ threadDelay 1_000_000 if exists - then return () + then logEvent $ AwaitedTx txId else go $ n - 1 failLeft :: (MonadFail m, Show s) => Either s a -> m a @@ -221,7 +221,10 @@ resolveTxAndSubmit :: (MonadQueryUtxo m, MonadSubmitTx m, MonadIO m) => TxSpec -> m (Either TxResolutionError TxId) -resolveTxAndSubmit spec = runExceptT $ do - resolved <- ExceptT $ resolveTx spec - let result = submitResolvedTx resolved - ExceptT $ first UnhandledSubmittingError <$> result +resolveTxAndSubmit spec = do + result <- runExceptT $ do + resolved <- ExceptT $ resolveTx spec + let result = submitResolvedTx resolved + ExceptT $ first UnhandledSubmittingError <$> result + logEvent $ SubmittedTxSpec spec result + return result diff --git a/src/Cardano/CEM/Testing/StateMachine.hs b/src/Cardano/CEM/Testing/StateMachine.hs index 28bf074..22265d8 100644 --- a/src/Cardano/CEM/Testing/StateMachine.hs +++ b/src/Cardano/CEM/Testing/StateMachine.hs @@ -40,8 +40,8 @@ import Text.Show.Pretty (ppShow) import Cardano.CEM (CEMParams (..)) import Cardano.CEM hiding (scriptParams) -import Cardano.CEM.Monads (MonadSubmitTx (..), ResolvedTx (..)) -import Cardano.CEM.Monads.CLB (execOnIsolatedClb) +import Cardano.CEM.Monads (CEMAction (..), MonadSubmitTx (..), ResolvedTx (..), SomeCEMAction (..), TxSpec (..)) +import Cardano.CEM.Monads.CLB (ClbRunner, execOnIsolatedClb) import Cardano.CEM.OffChain import Cardano.CEM.OnChain (CEMScriptCompiled) import Cardano.Extras (signingKeyToPKH) @@ -329,14 +329,14 @@ instance runActionsInClb :: forall state. - (StateModel (ScriptState state), RunModel (ScriptState state) (ClbT IO)) => + (StateModel (ScriptState state), RunModel (ScriptState state) ClbRunner) => Value -> Actions (ScriptState state) -> Property runActionsInClb genesisValue actions = monadic (ioProperty . execOnIsolatedClb genesisValue) $ void $ - runActions @(ScriptState state) @(ClbT IO) actions + runActions @(ScriptState state) @(ClbRunner) actions -- Orphans diff --git a/test/Utils.hs b/test/Utils.hs index 3491218..eb4ca8f 100644 --- a/test/Utils.hs +++ b/test/Utils.hs @@ -3,6 +3,8 @@ module Utils where import Prelude import Data.Map (keys) +import Data.Map qualified as Map +import Data.Maybe (mapMaybe) import PlutusLedgerApi.V1.Interval (always) import PlutusLedgerApi.V1.Value (assetClassValue) @@ -17,28 +19,31 @@ import Cardano.Api.Shelley ( import Test.Hspec (shouldSatisfy) import Text.Show.Pretty (ppShow) -import Clb (ClbT) - import Cardano.CEM.Monads ( + BlockchainMonadEvent (..), + CEMAction (..), + Fees (..), + MonadBlockchainParams (..), MonadQueryUtxo (..), MonadSubmitTx (..), ResolvedTx (..), + SomeCEMAction (..), + TxSpec (..), UtxoQuery (..), + submitResolvedTx, ) -import Cardano.CEM.Monads.CLB (execOnIsolatedClb) +import Cardano.CEM.Monads.CLB (ClbRunner, execOnIsolatedClb) import Cardano.CEM.OffChain ( - CEMAction (..), - SomeCEMAction (..), - TxSpec (..), awaitTx, fromPlutusAddressInMonad, resolveTxAndSubmit, ) import Cardano.Extras +import Data.Spine (HasSpine (..)) import TestNFT -execClb :: ClbT IO a -> IO a +execClb :: ClbRunner a -> IO a execClb = execOnIsolatedClb $ lovelaceToValue $ fromInteger 300_000_000 mintTestTokens :: @@ -108,3 +113,19 @@ submitAndCheck spec = do MkSomeCEMAction (MkCEMAction _ transition) -> liftIO $ putStrLn $ "Doing " <> show transition awaitEitherTx =<< resolveTxAndSubmit spec + +perTransitionStats :: (MonadBlockchainParams m) => m (Map.Map String Fees) +perTransitionStats = do + events <- eventList + let feesByTxId = Map.fromList $ mapMaybe txIdFeePair events + return $ Map.fromList $ mapMaybe (transitionFeePair feesByTxId) events + where + txIdFeePair (UserSpentFee {fees, txId}) = Just (txId, fees) + txIdFeePair _ = Nothing + transitionFeePair feesByTxId event = case event of + ( SubmittedTxSpec + (MkTxSpec [MkSomeCEMAction (MkCEMAction _ transition)] _) + (Right txId) + ) -> + Just (show (getSpine transition), feesByTxId Map.! txId) + _ -> Nothing diff --git a/test/Voting.hs b/test/Voting.hs index ec3f432..b0d3e35 100644 --- a/test/Voting.hs +++ b/test/Voting.hs @@ -9,7 +9,7 @@ import Test.Hspec (describe, shouldBe) import Cardano.CEM import Cardano.CEM.Examples.Compilation () import Cardano.CEM.Examples.Voting -import Cardano.CEM.Monads (MonadTest (..)) +import Cardano.CEM.Monads import Cardano.CEM.OffChain import Cardano.CEM.Stages import Cardano.Extras (signingKeyToPKH)