merging logging

CHANGELOG.md

@@ -9,10 +9,13 @@
 - `toInitDistWithMinAda` and `unsafeToInitDistWithMinAda` to ensure the initial
   distribution only provides outputs with the required minimal ada based on
   default parameters.
-
+- PrettyCooked option `pcOptLog`, which is a boolean, to turn on or off the log
+  display in the pretty printer. The default value is `True`.
+
 ### Removed
 
 - `positivePart` and `negativePart` in `ValueUtils.hs`. Replaced by `Api.split`.
+- Redundant logging of errors in mockchain runs.
 
 ### Changed
 
@@ -22,6 +25,11 @@
   constructors: `txSkelSomeRedeemer`, `txSkelEmptyRedeemer`,
   `txSkelSomeRedeemerAndReferenceScript`,
   `txSkelEmptyRedeemerAndReferenceScript`.
+- Logging has been reworked: 
+  * it is no longer limited to `StagedMockChain` runs
+  * it is now a component of `MonadBlockChainBalancing`
+  * it can be turned on/off in skeleton options
+  * it now displays the discarding of utxos during balancing.
 
 ### Fixed
 

src/Cooked/MockChain.hs

@@ -3,14 +3,10 @@
 module Cooked.MockChain (module X) where
 
 import Cooked.MockChain.Balancing as X
-import Cooked.MockChain.BlockChain as X
-import Cooked.MockChain.Direct as X
+import Cooked.MockChain.BlockChain as X hiding (MockChainLogEntry)
+import Cooked.MockChain.Direct as X hiding (MockChainReturn)
 import Cooked.MockChain.MinAda as X
-import Cooked.MockChain.Staged as X hiding
-  ( MockChainLog,
-    MockChainLogEntry,
-    StagedMockChain,
-  )
+import Cooked.MockChain.Staged as X hiding (StagedMockChain)
 import Cooked.MockChain.Testing as X
 import Cooked.MockChain.UtxoSearch as X
 import Cooked.MockChain.UtxoState as X (UtxoState)

src/Cooked/MockChain/Balancing.hs

@@ -12,6 +12,7 @@ import Cardano.Api.Ledger qualified as Cardano
 import Cardano.Api.Shelley qualified as Cardano
 import Cardano.Node.Emulator.Internal.Node.Params qualified as Emulator
 import Cardano.Node.Emulator.Internal.Node.Validation qualified as Emulator
+import Control.Monad
 import Control.Monad.Except
 import Cooked.Conversion
 import Cooked.MockChain.BlockChain
@@ -99,12 +100,21 @@ balanceTxSkel skelUnbal@TxSkel {..} = do
             ManualFee fee' -> fee'
        in (skelUnbal,fee,) <$> collateralsFromFees fee mCollaterals
     Just bWallet -> do
-      -- The balancing should be performed. We collect the balancing utxos and
-      -- filter out those already used in the unbalanced skeleton.
-      (filter ((`notElem` txSkelKnownTxOutRefs skelUnbal) . fst) -> balancingUtxos) <-
-        runUtxoSearch $ case txOptBalancingUtxos txSkelOpts of
-          BalancingUtxosFromBalancingWallet -> onlyValueOutputsAtSearch bWallet `filterWithAlways` outputTxOut
-          BalancingUtxosFromSet utxos -> txOutByRefSearch (Set.toList utxos) `filterWithPure` isPKOutput `filterWithAlways` outputTxOut
+      -- The balancing should be performed. We collect the candidates balancing
+      -- utxos based on the associated policy
+      balancingUtxos <-
+        case txOptBalancingUtxos txSkelOpts of
+          BalancingUtxosFromBalancingWallet -> runUtxoSearch $ onlyValueOutputsAtSearch bWallet `filterWithAlways` outputTxOut
+          BalancingUtxosFromSet utxos ->
+            -- We resolve the given set of utxos
+            runUtxoSearch (txOutByRefSearch (Set.toList utxos))
+              -- We filter out those belonging to scripts, while throwing a
+              -- warning if any was actually discarded.
+              >>= filterAndWarn (isJust . isPKOutput . snd) "They belong to scripts."
+          -- We filter the candidate utxos by removing those already present in the
+          -- skeleton, throwing a warning if any was actually discarder
+          >>= filterAndWarn ((`notElem` txSkelKnownTxOutRefs skelUnbal) . fst) "They are already used in the skeleton."
+
       case txOptFeePolicy txSkelOpts of
         -- If fees are left for us to compute, we run a dichotomic search. This
         -- is full auto mode, the most powerful but time-consuming.
@@ -118,6 +128,10 @@ balanceTxSkel skelUnbal@TxSkel {..} = do
           return (attemptedSkel, fee, adjustedMCollaterals)
 
   return (txSkelBal, fee, adjustedMCollaterals)
+  where
+    filterAndWarn f s l
+      | (ok, toInteger . length -> koLength) <- partition f l =
+          unless (koLength == 0) (publish $ MCLogDiscardedUtxos koLength s) >> return ok
 
 -- | This computes the minimum and maximum possible fee a transaction can cost
 -- based on the current protocol parameters

src/Cooked/MockChain/BlockChain.hs

@@ -15,6 +15,7 @@
 -- from the core definition of our blockchain.
 module Cooked.MockChain.BlockChain
   ( MockChainError (..),
+    MockChainLogEntry (..),
     MonadBlockChainBalancing (..),
     MonadBlockChainWithoutValidation (..),
     MonadBlockChain (..),
@@ -77,6 +78,7 @@ import Data.Kind
 import Data.Map (Map)
 import Data.Map qualified as Map
 import Data.Maybe
+import Data.Set (Set)
 import Ledger.Index qualified as Ledger
 import Ledger.Slot qualified as Ledger
 import Ledger.Tx qualified as Ledger
@@ -86,21 +88,20 @@ import Optics.Core
 import Plutus.Script.Utils.Scripts qualified as Script
 import PlutusLedgerApi.V3 qualified as Api
 
--- * BlockChain monad
+-- * MockChain errors
 
 -- | The errors that can be produced by the 'MockChainT' monad
 data MockChainError where
-  -- FIXME, maybe the validation phase can be deduced from the nature of the
-  -- error
+  -- | Validation errors, either in Phase 1 or Phase 2
   MCEValidationError :: Ledger.ValidationPhase -> Ledger.ValidationError -> MockChainError
   -- | Thrown when the balancing wallet does not have enough funds
   MCEUnbalanceable :: Wallet -> Api.Value -> TxSkel -> MockChainError
   -- | Thrown when not enough collateral are provided. Built upon the fee, the
   -- percentage and the expected minimal collateral value.
   MCENoSuitableCollateral :: Integer -> Integer -> Api.Value -> MockChainError
+  -- | Thrown when an error occured during transaction generation
   MCEGenerationError :: GenerateTxError -> MockChainError
-  -- | Thrown when an output reference should be in the state of the mockchain,
-  -- but isn't.
+  -- | Thrown when an output reference is missing from the mockchain state
   MCEUnknownOutRefError :: String -> Api.TxOutRef -> MockChainError
   -- | Same as 'MCEUnknownOutRefError' for validators.
   MCEUnknownValidator :: String -> Script.ValidatorHash -> MockChainError
@@ -110,9 +111,27 @@ data MockChainError where
   FailWith :: String -> MockChainError
   deriving (Show, Eq)
 
+-- * MockChain logs
+
+-- | This represents the specific events that should be logged when processing
+-- transactions. If a new kind of event arises, then a new constructor should be
+-- provided here.
+data MockChainLogEntry where
+  -- | Logging a Skeleton as it is submitted by the user.
+  MCLogSubmittedTxSkel :: SkelContext -> TxSkel -> MockChainLogEntry
+  -- | Logging a Skeleton as it has been adjusted by the balancing mechanism,
+  -- alongside fee, and possible collateral utxos and return collateral wallet.
+  MCLogAdjustedTxSkel :: SkelContext -> TxSkel -> Integer -> Maybe (Set Api.TxOutRef, Wallet) -> MockChainLogEntry
+  -- | Logging the appearance of a new transaction, after a skeleton has been
+  -- successfully sent for validation.
+  MCLogNewTx :: Api.TxId -> MockChainLogEntry
+  -- | Logging the fact that utxos provided by the user for balancing have to be
+  -- discarded for a specific reason.
+  MCLogDiscardedUtxos :: Integer -> String -> MockChainLogEntry
+
 -- | Contains methods needed for balancing.
 class (MonadFail m, MonadError MockChainError m) => MonadBlockChainBalancing m where
-  -- | Returns the parameters of the chain.
+  -- | Returns the emulator parameters, including protocol parameters
   getParams :: m Emulator.Params
 
   -- | Returns a list of all UTxOs at a certain address.
@@ -128,6 +147,9 @@ class (MonadFail m, MonadError MockChainError m) => MonadBlockChainBalancing m w
   -- | Returns an output given a reference to it
   txOutByRefLedger :: Api.TxOutRef -> m (Maybe Ledger.TxOut)
 
+  -- | Logs an event that occured during a BlockChain run
+  publish :: MockChainLogEntry -> m ()
+
 class (MonadBlockChainBalancing m) => MonadBlockChainWithoutValidation m where
   -- | Returns a list of all currently known outputs.
   allUtxosLedger :: m [(Api.TxOutRef, Ledger.TxOut)]
@@ -493,6 +515,7 @@ instance (MonadTrans t, MonadBlockChainBalancing m, Monad (t m), MonadError Mock
   utxosAtLedger = lift . utxosAtLedger
   txOutByRefLedger = lift . txOutByRefLedger
   datumFromHash = lift . datumFromHash
+  publish = lift . publish
 
 instance (MonadTrans t, MonadBlockChainWithoutValidation m, Monad (t m), MonadError MockChainError (AsTrans t m)) => MonadBlockChainWithoutValidation (AsTrans t m) where
   allUtxosLedger = lift allUtxosLedger
@@ -536,6 +559,7 @@ instance (MonadBlockChainBalancing m) => MonadBlockChainBalancing (ListT m) wher
   utxosAtLedger = lift . utxosAtLedger
   txOutByRefLedger = lift . txOutByRefLedger
   datumFromHash = lift . datumFromHash
+  publish = lift . publish
 
 instance (MonadBlockChainWithoutValidation m) => MonadBlockChainWithoutValidation (ListT m) where
   allUtxosLedger = lift allUtxosLedger

src/Cooked/MockChain/Direct.hs

@@ -16,6 +16,7 @@ import Control.Monad.Except
 import Control.Monad.Identity
 import Control.Monad.Reader
 import Control.Monad.State.Strict
+import Control.Monad.Writer
 import Cooked.Conversion.ToScript
 import Cooked.Conversion.ToScriptHash
 import Cooked.InitialDistribution
@@ -97,6 +98,12 @@ data MockChainSt = MockChainSt
   }
   deriving (Show)
 
+mcstToSkelContext :: MockChainSt -> SkelContext
+mcstToSkelContext MockChainSt {..} =
+  SkelContext
+    (txOutV2FromLedger <$> getIndex mcstIndex)
+    (Map.map fst mcstDatums)
+
 -- | Generating an emulated state for the emulator from a mockchain state and
 -- some parameters, based on a standard initial state
 mcstToEmulatedLedgerState :: MockChainSt -> Emulator.EmulatedLedgerState
@@ -129,8 +136,8 @@ instance Eq MockChainSt where
         ]
 
 newtype MockChainT m a = MockChainT
-  {unMockChain :: StateT MockChainSt (ExceptT MockChainError m) a}
-  deriving newtype (Functor, Applicative, MonadState MockChainSt, MonadError MockChainError)
+  {unMockChain :: (StateT MockChainSt (ExceptT MockChainError (WriterT [MockChainLogEntry] m))) a}
+  deriving newtype (Functor, Applicative, MonadState MockChainSt, MonadError MockChainError, MonadWriter [MockChainLogEntry])
 
 type MockChain = MockChainT Identity
 
@@ -143,10 +150,10 @@ instance (Monad m) => MonadFail (MockChainT m) where
   fail = throwError . FailWith
 
 instance MonadTrans MockChainT where
-  lift = MockChainT . lift . lift
+  lift = MockChainT . lift . lift . lift
 
 instance (Monad m, Alternative m) => Alternative (MockChainT m) where
-  empty = MockChainT $ StateT $ const $ ExceptT empty
+  empty = MockChainT $ StateT $ const $ ExceptT $ WriterT empty
   (<|>) = combineMockChainT (<|>)
 
 combineMockChainT ::
@@ -157,24 +164,26 @@ combineMockChainT ::
   MockChainT m x
 combineMockChainT f ma mb = MockChainT $
   StateT $ \s ->
-    let resA = runExceptT $ runStateT (unMockChain ma) s
-        resB = runExceptT $ runStateT (unMockChain mb) s
-     in ExceptT $ f resA resB
+    let resA = runWriterT $ runExceptT $ runStateT (unMockChain ma) s
+        resB = runWriterT $ runExceptT $ runStateT (unMockChain mb) s
+     in ExceptT $ WriterT $ f resA resB
+
+type MockChainReturn a b = (Either MockChainError (a, b), [MockChainLogEntry])
 
 mapMockChainT ::
-  (m (Either MockChainError (a, MockChainSt)) -> n (Either MockChainError (b, MockChainSt))) ->
+  (m (MockChainReturn a MockChainSt) -> n (MockChainReturn b MockChainSt)) ->
   MockChainT m a ->
   MockChainT n b
-mapMockChainT f = MockChainT . mapStateT (mapExceptT f) . unMockChain
+mapMockChainT f = MockChainT . mapStateT (mapExceptT (mapWriterT f)) . unMockChain
 
 -- | Executes a 'MockChainT' from some initial state; does /not/ convert the
 -- 'MockChainSt' into a 'UtxoState'.
 runMockChainTRaw ::
   (Monad m) =>
   MockChainSt ->
   MockChainT m a ->
-  m (Either MockChainError (a, MockChainSt))
-runMockChainTRaw i0 = runExceptT . flip runStateT i0 . unMockChain
+  m (MockChainReturn a MockChainSt)
+runMockChainTRaw i0 = runWriterT . runExceptT . flip runStateT i0 . unMockChain
 
 -- | Executes a 'MockChainT' from an initial state set up with the given initial
 -- value distribution. Similar to 'runMockChainT', uses the default
@@ -184,25 +193,25 @@ runMockChainTFrom ::
   (Monad m) =>
   InitialDistribution ->
   MockChainT m a ->
-  m (Either MockChainError (a, UtxoState))
-runMockChainTFrom i0 = fmap (fmap $ second mcstToUtxoState) . runMockChainTRaw (mockChainSt0From i0)
+  m (MockChainReturn a UtxoState)
+runMockChainTFrom i0 s = first (right (second mcstToUtxoState)) <$> runMockChainTRaw (mockChainSt0From i0) s
 
 -- | Executes a 'MockChainT' from the canonical initial state and environment.
 -- The canonical environment uses the default 'SlotConfig' and
 -- @Cooked.Wallet.wallet 1@ as the sole wallet signing transactions.
-runMockChainT :: (Monad m) => MockChainT m a -> m (Either MockChainError (a, UtxoState))
+runMockChainT :: (Monad m) => MockChainT m a -> m (MockChainReturn a UtxoState)
 runMockChainT = runMockChainTFrom def
 
 -- | See 'runMockChainTRaw'
-runMockChainRaw :: MockChain a -> Either MockChainError (a, MockChainSt)
+runMockChainRaw :: MockChain a -> MockChainReturn a MockChainSt
 runMockChainRaw = runIdentity . runMockChainTRaw def
 
 -- | See 'runMockChainTFrom'
-runMockChainFrom :: InitialDistribution -> MockChain a -> Either MockChainError (a, UtxoState)
+runMockChainFrom :: InitialDistribution -> MockChain a -> MockChainReturn a UtxoState
 runMockChainFrom i0 = runIdentity . runMockChainTFrom i0
 
 -- | See 'runMockChainT'
-runMockChain :: MockChain a -> Either MockChainError (a, UtxoState)
+runMockChain :: MockChain a -> MockChainReturn a UtxoState
 runMockChain = runIdentity . runMockChainT
 
 -- * Canonical initial values
@@ -316,6 +325,7 @@ instance (Monad m) => MonadBlockChainBalancing (MockChainT m) where
   txOutByRefLedger outref = gets $ Map.lookup outref . getIndex . mcstIndex
   datumFromHash datumHash = (txSkelOutUntypedDatum <=< Just . fst <=< Map.lookup datumHash) <$> gets mcstDatums
   utxosAtLedger addr = filter ((addr ==) . outputAddress . txOutV2FromLedger . snd) <$> allUtxosLedger
+  publish l = tell [l]
 
 instance (Monad m) => MonadBlockChainWithoutValidation (MockChainT m) where
   allUtxosLedger = gets $ Map.toList . getIndex . mcstIndex
@@ -325,6 +335,8 @@ instance (Monad m) => MonadBlockChainWithoutValidation (MockChainT m) where
 
 instance (Monad m) => MonadBlockChain (MockChainT m) where
   validateTxSkel skelUnbal = do
+    -- We log the submitted skeleton
+    gets mcstToSkelContext >>= publish . (`MCLogSubmittedTxSkel` skelUnbal)
     -- We retrieve the current parameters
     oldParams <- getParams
     -- We compute the optionally modified parameters
@@ -337,6 +349,8 @@ instance (Monad m) => MonadBlockChain (MockChainT m) where
     -- We balance the skeleton when requested in the skeleton option, and get
     -- the associated fee, collateral inputs and return collateral wallet
     (skel, fee, mCollaterals) <- balanceTxSkel minAdaSkelUnbal
+    -- We log the adjusted skeleton
+    gets mcstToSkelContext >>= \ctx -> publish $ MCLogAdjustedTxSkel ctx skel fee mCollaterals
     -- We retrieve data that will be used in the transaction generation process:
     -- datums, validators and various kinds of inputs. This idea is to provide a
     -- rich-enough context for the transaction generation to succeed.
@@ -388,6 +402,8 @@ instance (Monad m) => MonadBlockChain (MockChainT m) where
       modify' (\st -> st {mcstCurrentSlot = mcstCurrentSlot st + 1})
     -- We return the parameters to their original state
     setParams oldParams
+    -- We log the validated transaction
+    publish $ MCLogNewTx (Ledger.fromCardanoTxId $ Ledger.getCardanoTxId cardanoTx)
     -- We return the validated transaction
     return cardanoTx
     where