Merge pull request #95 from mlabs-haskell/uhbif19/structured-logs

Add structured logs interface and script fees recording

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

@@ -3,6 +3,7 @@ module Cardano.CEM.Monads where
 import Prelude
 
 import Data.Set (Set)
+import GHC.Natural (Natural)
 
 import PlutusLedgerApi.V1.Address (Address)
 import PlutusLedgerApi.V2 (
@@ -14,10 +15,39 @@ import PlutusLedgerApi.V2 (
 import Cardano.Api hiding (Address, In, Out, queryUtxo, txIns)
 import Cardano.Api.Shelley (PoolId)
 import Cardano.Ledger.Core (PParams)
-import Cardano.Ledger.Shelley.API (ApplyTxError (..))
+import Cardano.Ledger.Shelley.API (ApplyTxError (..), Coin)
 
+import Cardano.CEM
+import Cardano.CEM.OnChain
 import Cardano.Extras
 
+-- CEMAction and TxSpec
+
+data CEMAction script
+  = MkCEMAction (CEMParams script) (Transition script)
+
+deriving stock instance
+  (CEMScript script) => Show (CEMAction script)
+
+-- FIXME: use generic Some
+data SomeCEMAction where
+  MkSomeCEMAction ::
+    forall script.
+    (CEMScriptCompiled script) =>
+    CEMAction script ->
+    SomeCEMAction
+
+instance Show SomeCEMAction where
+  -- FIXME: show script name
+  show :: SomeCEMAction -> String
+  show (MkSomeCEMAction action) = show action
+
+data TxSpec = MkTxSpec
+  { actions :: [SomeCEMAction]
+  , specSigner :: SigningKey PaymentKey
+  }
+  deriving stock (Show)
+
 -- MonadBlockchainParams
 
 -- | Params of blockchain required for transaction-building
@@ -30,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
 
@@ -73,6 +124,20 @@ data TxSubmittingError
   | UnhandledNodeSubmissionError (ApplyTxError LedgerEra)
   deriving stock (Show)
 
+-- | Error occurred while trying to execute CEMScript transition
+data TransitionError
+  = StateMachineError
+      { errorMessage :: String
+      }
+  | MissingTransitionInput
+  deriving stock (Show, Eq)
+
+data TxResolutionError
+  = TxSpecIsIncorrect
+  | MkTransitionError SomeCEMAction TransitionError
+  | UnhandledSubmittingError TxSubmittingError
+  deriving stock (Show)
+
 -- | Ability to send transaction to chain
 class (MonadQueryUtxo m) => MonadSubmitTx m where
   submitResolvedTx :: ResolvedTx -> m (Either TxSubmittingError TxId)

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,48 +56,9 @@ awaitTx txId = do
       exists <- checkTxIdExists txId
       liftIO $ threadDelay 1_000_000
       if exists
-        then return ()
+        then logEvent $ AwaitedTx txId
         else go $ n - 1
 
-data CEMAction script
-  = MkCEMAction (CEMParams script) (Transition script)
-
-deriving stock instance
-  (CEMScript script) => Show (CEMAction script)
-
--- FIXME: use generic Some
-data SomeCEMAction where
-  MkSomeCEMAction ::
-    forall script.
-    (CEMScriptCompiled script) =>
-    CEMAction script ->
-    SomeCEMAction
-
-instance Show SomeCEMAction where
-  -- FIXME: show script name
-  show :: SomeCEMAction -> String
-  show (MkSomeCEMAction action) = show action
-
-data TxSpec = MkTxSpec
-  { actions :: [SomeCEMAction]
-  , specSigner :: SigningKey PaymentKey
-  }
-  deriving stock (Show)
-
--- | Error occurred while trying to execute CEMScript transition
-data TransitionError
-  = StateMachineError
-      { errorMessage :: String
-      }
-  | MissingTransitionInput
-  deriving stock (Show, Eq)
-
-data TxResolutionError
-  = TxSpecIsIncorrect
-  | MkTransitionError SomeCEMAction TransitionError
-  | UnhandledSubmittingError TxSubmittingError
-  deriving stock (Show)
-
 failLeft :: (MonadFail m, Show s) => Either s a -> m a
 failLeft (Left errorMsg) = fail $ show errorMsg
 failLeft (Right value) = return value
@@ -252,15 +213,18 @@ resolveTx spec = runExceptT $ do
   -- Merge specs
   let
     mergedSpec' = head actionsSpecs
-    mergedSpec = mergedSpec' {signer = specSigner spec}
+    mergedSpec = (mergedSpec' :: ResolvedTx) {signer = specSigner spec}
 
   return mergedSpec
 
 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