WIP more debugging

marlowe/src/Language/Marlowe/Client.hs

@@ -237,6 +237,7 @@ marlowePlutusContract = do
         let tx = mustPayToTheScript marloweData payValue <> distributeRoleTokens
         let lookups = Constraints.scriptInstanceLookups validatorInstance
         utx <- either (throwing _ConstraintResolutionError) pure (Constraints.mkTx lookups tx)
+        logWarn @String "Sumitting tx"
         submitTxConfirmed utx
         marlowePlutusContract
     apply = do

plutus-pab/app/Main.hs

@@ -30,6 +30,7 @@ import           Data.Yaml                               (decodeFileThrow)
 import           Plutus.PAB.Effects.Contract.ContractExe (ContractExe)
 import           Plutus.PAB.Monitoring.Config            (defaultConfig, loadConfig)
 import           Plutus.PAB.Monitoring.PABLogMsg         (AppMsg (..))
+import           Plutus.PAB.Monitoring.Util              (PrettyObject (..), convertLog)
 import           Plutus.PAB.Types                        (PABError)
 import           System.Exit                             (ExitCode (ExitFailure), exitSuccess, exitWith)
 
@@ -41,7 +42,7 @@ main = do
     config <- liftIO $ decodeFileThrow configPath
     logConfig <- maybe defaultConfig loadConfig logConfigPath
     for_ minLogLevel $ \ll -> CM.setMinSeverity logConfig ll
-    (trace :: Trace IO (AppMsg ContractExe), switchboard) <- setupTrace_ logConfig "pab"
+    (trace :: Trace IO (PrettyObject (AppMsg ContractExe)), switchboard) <- setupTrace_ logConfig "pab"
 
     -- enable EKG backend
     when runEkgServer $ EKGView.plugin logConfig trace switchboard >>= loadPlugin switchboard
@@ -50,7 +51,7 @@ main = do
     serviceAvailability <- newToken
 
     -- execute parsed pab command and handle errors on faliure
-    result <- executePABCommand trace logConfig config serviceAvailability cmd
+    result <- executePABCommand (convertLog PrettyObject trace) logConfig config serviceAvailability cmd
     either handleError (const exitSuccess) result
 
         where

plutus-pab/src/Cardano/Protocol/Socket/Server.hs

@@ -138,8 +138,10 @@ pruneChain k original = do
        {- When the counter reaches zero, there are K blocks in the
           original channel and we start to remove the oldest stored
           block by reading it. -}
-       then liftIO $ atomically (readTChan original) >> go 0 localChannel
-       else go (k' - 1) localChannel
+       then do
+           liftIO $ atomically (readTChan original) >> go 0 localChannel
+       else do
+           go (k' - 1) localChannel
 
 handleCommand ::
     MonadIO m
@@ -230,11 +232,14 @@ nextState localChannel@(LocalChannel channel') = do
     chainState <- ask
     tip' <- getTip chainState
     (liftIO . atomically $ tryReadTChan channel') >>= \case
-        Nothing -> Right . pure <$> do
-            nextBlock <- liftIO . atomically $ readTChan channel'
-            liftIO $ modifyMVar_ chainState (pure . (tip ?~ nextBlock))
-            sendRollForward localChannel tip' nextBlock
+        Nothing -> do
+            -- liftIO $ putStrLn $ "Socket.Server: nextState Nothing" -- happens too often
+            Right . pure <$> do
+                nextBlock <- liftIO . atomically $ readTChan channel'
+                liftIO $ modifyMVar_ chainState (pure . (tip ?~ nextBlock))
+                sendRollForward localChannel tip' nextBlock
         Just nextBlock -> do
+            -- liftIO $ putStrLn $ "Socket.Server: nextState Just" -- happens too often
             liftIO $ modifyMVar_ chainState (pure . (tip ?~ nextBlock))
             Left <$> sendRollForward localChannel tip' nextBlock
 
@@ -248,6 +253,7 @@ findIntersect ::
  => [Point Block]
  -> m (ServerStIntersect Block (Point Block) Tip m ())
 findIntersect clientPoints = do
+    liftIO $ putStrLn "findIntersect"
     mvState <- ask
     chainState <- liftIO $ readMVar mvState
     serverPoints <- getChainPoints (view channel chainState) chainState
@@ -303,6 +309,7 @@ cloneChainFrom offset = (LocalChannel <$>) <$> go
   where
     go :: m (Maybe (TChan Block))
     go = do
+        liftIO $ putStrLn $ "cloneChainFrom: " <> show offset
         globalChannel <- ask >>= getChannel
         liftIO $ atomically $ do
             localChannel <- cloneTChan globalChannel

plutus-pab/src/Plutus/PAB/Core/ContractInstance/BlockchainEnv.hs

@@ -9,7 +9,6 @@ module Plutus.PAB.Core.ContractInstance.BlockchainEnv(
   , ClientEnv(..)
   , processBlock
   , getClientEnv
-  , updateInterestingAddresses
   ) where
 
 import qualified Cardano.Protocol.Socket.Client       as Client
@@ -25,7 +24,7 @@ import           Control.Concurrent                   (forkIO)
 import           Control.Concurrent.STM               (STM)
 import qualified Control.Concurrent.STM               as STM
 import           Control.Lens
-import           Control.Monad                        (guard, when)
+import           Control.Monad                        (guard, unless, when)
 import           Data.Foldable                        (foldl')
 import           Data.Map                             (Map)
 import           Data.Set                             (Set)
@@ -42,8 +41,9 @@ startNodeClient ::
   -> IO BlockchainEnv
 startNodeClient socket slotConfig instancesState =  do
     env <- STM.atomically emptyBlockchainEnv
-    _ <- Client.runClientNode socket slotConfig (\block -> STM.atomically . processBlock env block)
-    _ <- forkIO (clientEnvLoop env instancesState)
+    _ <- Client.runClientNode socket slotConfig $ \block slot -> do
+          unless (null block) $ putStrLn $ "node client block: " <> show (txId <$> block)
+          STM.atomically $ processBlock env block slot
     pure env
 
 -- | Interesting addresses and transactions from all the
@@ -66,29 +66,23 @@ nextClientEnv instancesState currentEnv = do
   guard $ newEnv /= currentEnv
   pure newEnv
 
-clientEnvLoop :: BlockchainEnv -> InstancesState -> IO ()
-clientEnvLoop env instancesState = go initialClientEnv where
-  go currentEnv = do
-    STM.atomically (updateInterestingAddresses env currentEnv)
-    STM.atomically (nextClientEnv instancesState currentEnv) >>= go
-
-updateInterestingAddresses :: BlockchainEnv -> ClientEnv -> STM ()
-updateInterestingAddresses BlockchainEnv{beAddressMap} ClientEnv{ceAddresses} = do
-  STM.modifyTVar beAddressMap (AddressMap.addAddresses (Set.toList ceAddresses))
-
 -- | Go through the transactions in a block, updating the 'BlockchainEnv'
 --   when any interesting addresses or transactions have changed.
 processBlock :: BlockchainEnv -> Block -> Slot -> STM ()
 processBlock BlockchainEnv{beAddressMap, beTxChanges, beCurrentSlot, beTxIndex} transactions slot = do
-  addressMap <- STM.readTVar beAddressMap
-  chainIndex <- STM.readTVar beTxIndex
-  txStatusMap <- STM.readTVar beTxChanges
-  let (addressMap', txStatusMap', chainIndex') = foldl' (processTx slot) (addressMap, S.increaseDepth <$> txStatusMap, chainIndex) transactions
-  STM.writeTVar beAddressMap addressMap'
-  STM.writeTVar beTxChanges txStatusMap'
-  STM.writeTVar beTxIndex chainIndex'
   lastSlot <- STM.readTVar beCurrentSlot
-  when (slot /= lastSlot) (STM.writeTVar beCurrentSlot slot)
+  when (slot > lastSlot) $ do
+    STM.modifyTVar beTxChanges (fmap S.increaseDepth)
+    STM.writeTVar beCurrentSlot slot
+  unless (null transactions) $ do
+    addressMap <- STM.readTVar beAddressMap
+    chainIndex <- STM.readTVar beTxIndex
+    txStatusMap <- STM.readTVar beTxChanges
+    let (addressMap', txStatusMap', chainIndex') = foldl' (processTx slot) (addressMap, txStatusMap, chainIndex) transactions
+    STM.writeTVar beAddressMap addressMap'
+    STM.writeTVar beTxChanges txStatusMap'
+    STM.writeTVar beTxIndex chainIndex'
+
 
 processTx :: Slot -> (AddressMap, Map TxId TxStatus, ChainIndex) -> Tx -> (AddressMap, Map TxId TxStatus, ChainIndex)
 processTx currentSlot (addressMap, txStatusMap, chainIndex) tx = (addressMap', txStatusMap', chainIndex') where

plutus-pab/src/Plutus/PAB/Core/ContractInstance/STM.hs

@@ -368,7 +368,7 @@ watchedTransactions (InstancesState m) = do
 waitForTxConfirmed :: TxId -> BlockchainEnv -> STM TxConfirmed
 waitForTxConfirmed tx BlockchainEnv{beTxChanges} = do
     idx <- STM.readTVar beTxChanges
-    let minDepth = 5 -- how many blocks the tx must be into the chain
+    let minDepth = 8 -- how many blocks the tx must be into the chain
     guard $ maybe False (isConfirmed minDepth) (Map.lookup tx idx)
     pure (TxConfirmed tx)
 

plutus-pab/src/Plutus/PAB/Monitoring/Util.hs

@@ -1,12 +1,13 @@
-{-# LANGUAGE DataKinds         #-}
-{-# LANGUAGE FlexibleContexts  #-}
-{-# LANGUAGE GADTs             #-}
-{-# LANGUAGE LambdaCase        #-}
-{-# LANGUAGE NamedFieldPuns    #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes        #-}
-{-# LANGUAGE TypeApplications  #-}
-{-# LANGUAGE TypeOperators     #-}
+{-# LANGUAGE DataKinds          #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts   #-}
+{-# LANGUAGE GADTs              #-}
+{-# LANGUAGE LambdaCase         #-}
+{-# LANGUAGE NamedFieldPuns     #-}
+{-# LANGUAGE OverloadedStrings  #-}
+{-# LANGUAGE RankNTypes         #-}
+{-# LANGUAGE TypeApplications   #-}
+{-# LANGUAGE TypeOperators      #-}
 
 module Plutus.PAB.Monitoring.Util (
       handleLogMsgTrace
@@ -15,27 +16,34 @@ module Plutus.PAB.Monitoring.Util (
     , runLogEffects
     , convertLog
     , toSeverity
+    , PrettyObject(..)
     ) where
 
-import qualified Cardano.BM.Configuration.Model as CM
+import qualified Cardano.BM.Configuration.Model        as CM
 import           Cardano.BM.Data.Counter
 import           Cardano.BM.Data.LogItem
 import           Cardano.BM.Data.Severity
 import           Cardano.BM.Data.SubTrace
 import           Cardano.BM.Data.Trace
+import           Cardano.BM.Data.Tracer                (ToObject (..))
 import           Cardano.BM.Observer.Monadic
 import           Cardano.BM.Trace
-import           Control.Monad                  (void)
-import           Control.Monad.Catch            (MonadCatch)
+import           Control.Monad                         (void)
+import           Control.Monad.Catch                   (MonadCatch)
 import           Control.Monad.Freer
-import           Control.Monad.Freer.Extras.Log (LogMsg (..), LogObserve (..), Observation (..))
-import qualified Control.Monad.Freer.Extras.Log as L
-import           Control.Monad.IO.Class         (MonadIO (..))
-import           Data.Bifunctor                 (Bifunctor (..))
-import           Data.Foldable                  (for_)
-import           Data.Functor.Contravariant     (Contravariant (..))
-import           Data.Maybe                     (fromMaybe)
-import           Data.Text                      (Text)
+import           Control.Monad.Freer.Extras.Log        (LogMsg (..), LogObserve (..), Observation (..))
+import qualified Control.Monad.Freer.Extras.Log        as L
+import           Control.Monad.IO.Class                (MonadIO (..))
+import           Data.Aeson                            (FromJSON, ToJSON (..))
+import           Data.Bifunctor                        (Bifunctor (..))
+import           Data.Foldable                         (for_)
+import           Data.Functor.Contravariant            (Contravariant (..))
+import qualified Data.HashMap.Strict                   as HM
+import           Data.Maybe                            (fromMaybe)
+import           Data.Text                             (Text)
+import qualified Data.Text.Lazy                        as Text
+import           Data.Text.Prettyprint.Doc             (Pretty (..), defaultLayoutOptions, layoutPretty)
+import qualified Data.Text.Prettyprint.Doc.Render.Text as Render
 
 toSeverity :: L.LogLevel -> Severity
 toSeverity = \case
@@ -128,3 +136,13 @@ handleObserveTrace config t =
   in L.handleObserve
       observeBefore
       observeAfter
+
+-- | A 'ToObject' instance that uses 'Pretty' as its 'textTransformer'
+newtype PrettyObject t = PrettyObject { unPrettyObject :: t }
+    deriving newtype (ToJSON, FromJSON)
+
+instance (Pretty t) => ToObject (PrettyObject t) where
+    toObject v (PrettyObject t) =
+        let str = Text.toStrict . Render.renderLazy . layoutPretty defaultLayoutOptions $ pretty t in
+        HM.singleton "string" (toJSON str)
+    textTransformer (PrettyObject t) _ = Text.toStrict . Render.renderLazy . layoutPretty defaultLayoutOptions $ pretty t

plutus-pab/src/Plutus/PAB/Simulator.hs

@@ -104,8 +104,7 @@ import           Plutus.Contract.Effects.AwaitTxConfirmed       (TxConfirmed)
 import           Plutus.PAB.Core                                (EffectHandlers (..))
 import qualified Plutus.PAB.Core                                as Core
 import qualified Plutus.PAB.Core.ContractInstance.BlockchainEnv as BlockchainEnv
-import           Plutus.PAB.Core.ContractInstance.STM           (Activity (..), BlockchainEnv, InstancesState,
-                                                                 OpenEndpoint)
+import           Plutus.PAB.Core.ContractInstance.STM           (Activity (..), BlockchainEnv, OpenEndpoint)
 import qualified Plutus.PAB.Core.ContractInstance.STM           as Instances
 import           Plutus.PAB.Effects.Contract                    (ContractStore)
 import qualified Plutus.PAB.Effects.Contract                    as Contract
@@ -225,7 +224,6 @@ mkSimulatorHandlers definitions handleContractEffect =
                 $ handleDelayEffect
                 $ interpret (Core.handleUserEnvReader @t @(SimulatorState t))
                 $ interpret (Core.handleBlockchainEnvReader @t @(SimulatorState t))
-                $ interpret (Core.handleInstancesStateReader @t @(SimulatorState t))
                 $ advanceClock @t
             Core.waitUntilSlot 1
         , onShutdown = do
@@ -350,7 +348,6 @@ makeBlock ::
     forall t effs.
     ( LastMember IO effs
     , Member (Reader (SimulatorState t)) effs
-    , Member (Reader InstancesState) effs
     , Member (Reader BlockchainEnv) effs
     , Member DelayEffect effs
     , Member TimeEffect effs
@@ -445,7 +442,6 @@ handleChainControl ::
     ( LastMember IO effs
     , Member (Reader (SimulatorState t)) effs
     , Member (Reader BlockchainEnv) effs
-    , Member (Reader InstancesState) effs
     , Member (LogMsg Chain.ChainEvent) effs
     , Member (LogMsg ChainIndex.ChainIndexEvent) effs
     )
@@ -454,14 +450,10 @@ handleChainControl ::
 handleChainControl = \case
     Chain.ProcessBlock -> do
         blockchainEnv <- ask @BlockchainEnv
-        instancesState <- ask @InstancesState
         (txns, slot) <- runChainEffects @t @_ ((,) <$> Chain.processBlock <*> Chain.getCurrentSlot)
         runChainIndexEffects @t (ChainIndex.chainIndexNotify $ BlockValidated txns)
 
-        void $ liftIO $ STM.atomically $ do
-            cenv <- BlockchainEnv.getClientEnv instancesState
-            BlockchainEnv.updateInterestingAddresses blockchainEnv cenv
-            BlockchainEnv.processBlock blockchainEnv txns slot
+        void $ liftIO $ STM.atomically $ BlockchainEnv.processBlock blockchainEnv txns slot
         pure txns
     Chain.ModifySlot f -> do
         slot <- runChainEffects @t @_ (Chain.modifySlot f)
@@ -598,7 +590,6 @@ advanceClock ::
     forall t effs.
     ( LastMember IO effs
     , Member (Reader (SimulatorState t)) effs
-    , Member (Reader InstancesState) effs
     , Member (Reader BlockchainEnv) effs
     , Member DelayEffect effs
     , Member TimeEffect effs