Add structured logs interface and script fees recording

Also updates CLB dep

Author: uhbif19

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

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
 

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

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

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
 

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

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
 

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

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)