Skip to content

Commit

Permalink
Improve logging
Browse files Browse the repository at this point in the history
  • Loading branch information
@j-mueller
j-mueller committed Mar 2, 2021
1 parent 9c54f52 commit 27c6c5f
Show file tree
Hide file tree
Showing 4 changed files with 64 additions and 53 deletions.
7 changes: 3 additions & 4 deletions plutus-pab/src/Plutus/PAB/Core/ContractInstance/BlockchainEnv.hs
View file
Expand Up @@ -10,7 +10,7 @@ module Plutus.PAB.Core.ContractInstance.BlockchainEnv(
) where

import qualified Cardano.Protocol.Socket.Client as Client
import Ledger (Address, Block, Tx, TxId, txId, Slot)
import Ledger (Address, Block, Slot, Tx, TxId, txId)
import Ledger.AddressMap (AddressMap)
import qualified Ledger.AddressMap as AddressMap
import Plutus.PAB.Core.ContractInstance.STM (BlockchainEnv (..), InstancesState, TxStatus (..),
Expand All @@ -26,8 +26,8 @@ import Data.Foldable (foldl')
import Data.Map (Map)
import Data.Set (Set)
import qualified Data.Set as Set
import Wallet.Emulator.ChainIndex.Index (ChainIndex, ChainIndexItem(..))
import qualified Wallet.Emulator.ChainIndex.Index as Index
import Wallet.Emulator.ChainIndex.Index (ChainIndex, ChainIndexItem (..))
import qualified Wallet.Emulator.ChainIndex.Index as Index

-- | Connect to the node and write node updates to the blockchain
-- env.
Expand Down Expand Up @@ -67,7 +67,6 @@ clientEnvLoop env instancesState = go initialClientEnv where

updateInterestingAddresses :: BlockchainEnv -> ClientEnv -> IO ()
updateInterestingAddresses BlockchainEnv{beAddressMap} ClientEnv{ceAddresses} = do
putStrLn "updateInterestingAddresses"
STM.atomically $ STM.modifyTVar beAddressMap (AddressMap.addAddresses (Set.toList ceAddresses))

-- | Go through the transactions in a block, updating the 'BlockchainEnv'
Expand Down
5 changes: 5 additions & 0 deletions plutus-pab/src/Plutus/PAB/Core/ContractInstance/RequestHandlers.hs
View file
Expand Up @@ -52,6 +52,7 @@ import Plutus.PAB.Types (Source (NodeEven
import Wallet.Effects (ChainIndexEffect, ContractRuntimeEffect,
SigningProcessEffect, WalletEffect)
import Wallet.Emulator.LogMessages (TxBalanceMsg)
import Wallet.Types (NotificationError)

processOwnPubkeyRequests ::
forall effs.
Expand Down Expand Up @@ -191,6 +192,7 @@ data ContractInstanceMsg t =
| HandlingRequests ContractInstanceId [Request ContractPABRequest]
| BalancingTx TxBalanceMsg
| MaxIterationsExceeded ContractInstanceId MaxIterations
| NotificationFailed NotificationError
deriving stock (Eq, Show, Generic)
deriving anyclass (ToJSON, FromJSON)

Expand Down Expand Up @@ -261,6 +263,8 @@ instance ToJSON v => ToObject (ContractInstanceMsg v) where
MaxIterationsExceeded instanceID maxIts ->
mkObjectStr "exceeded maximum number of iterations"
(instanceID, Tagged @"max_iterations" maxIts)
NotificationFailed _ ->
mkObjectStr "notification failed" ()

instance Pretty t => Pretty (ContractInstanceMsg t) where
pretty = \case
Expand Down Expand Up @@ -289,3 +293,4 @@ instance Pretty t => Pretty (ContractInstanceMsg t) where
HandlingRequests i rqs -> "Handling" <+> pretty (length rqs) <+> "requests for" <+> pretty i
BalancingTx msg -> pretty msg
MaxIterationsExceeded i (MaxIterations is) -> "Max iterations" <+> parens (pretty is) <+> "exceeded for" <+> pretty i
NotificationFailed e -> "Notification failed:" <+> pretty e
22 changes: 13 additions & 9 deletions plutus-pab/src/Plutus/PAB/Core/ContractInstance/STM.hs
View file
Expand Up @@ -50,7 +50,8 @@ import Ledger.AddressMap (AddressMap)
import Wallet.Emulator.ChainIndex.Index (ChainIndex)
import qualified Wallet.Emulator.ChainIndex.Index as Index
import Wallet.Types (AddressChangeRequest (..), AddressChangeResponse (..),
ContractInstanceId, EndpointDescription)
ContractInstanceId, EndpointDescription,
NotificationError (..))

{- Note [Contract instance thread model]
Expand Down Expand Up @@ -138,10 +139,10 @@ data TxStatus =
-- may be interested in.
data BlockchainEnv =
BlockchainEnv
{ beCurrentSlot :: TVar Slot
, beAddressMap :: TVar AddressMap
, beTxIndex :: TVar ChainIndex
, beTxChanges :: TVar (Map TxId TxStatus)
{ beCurrentSlot :: TVar Slot -- ^ Current slot
, beAddressMap :: TVar AddressMap -- ^ Address map used for updating the chain index
, beTxIndex :: TVar ChainIndex -- ^ Local chain index (not persisted)
, beTxChanges :: TVar (Map TxId TxStatus) -- ^ Map of transaction IDs to statuses
}

-- | Initialise an empty 'BlockchainEnv' value
Expand Down Expand Up @@ -170,6 +171,7 @@ awaitEndpointResponse Request{rqID, itID} InstanceState{issEndpoints} = do
Nothing -> empty
Just OpenEndpoint{oepResponse} -> STM.readTMVar oepResponse

-- | Whether the contract instance is still waiting for an event.
data Activity = Active | Done

-- | The state of an active contract instance.
Expand Down Expand Up @@ -221,18 +223,19 @@ openEndpoints = STM.readTVar . issEndpoints
callEndpoint :: OpenEndpoint -> EndpointValue Value -> STM ()
callEndpoint OpenEndpoint{oepResponse} = STM.putTMVar oepResponse

callEndpointOnInstance :: InstancesState -> EndpointDescription -> Value -> ContractInstanceId -> STM (Maybe String)
-- | Call an endpoint on a contract instance.
callEndpointOnInstance :: InstancesState -> EndpointDescription -> Value -> ContractInstanceId -> STM (Maybe NotificationError)
callEndpointOnInstance (InstancesState m) endpointDescription value instanceID = do
instances <- STM.readTVar m
case Map.lookup instanceID instances of
Nothing -> pure (Just "Instance not found")
Nothing -> pure $ Just $ InstanceDoesNotExist instanceID
Just is -> do
mp <- openEndpoints is
let match OpenEndpoint{oepName=ActiveEndpoint{aeDescription=d}} = endpointDescription == d
case filter match $ fmap snd $ Map.toList mp of
[] -> pure (Just "endpoint not active")
[] -> pure $ Just $ EndpointNotAvailable instanceID endpointDescription
[ep] -> callEndpoint ep (EndpointValue value) >> pure Nothing
_ -> pure (Just "endpoint active multiple times")
_ -> pure $ Just $ MoreThanOneEndpointAvailable instanceID endpointDescription

-- | State of all contract instances that are currently running
newtype InstancesState = InstancesState (TVar (Map ContractInstanceId InstanceState))
Expand All @@ -259,6 +262,7 @@ watchedTransactions (InstancesState m) = do
allSets <- traverse (STM.readTVar . issTransactions) (snd <$> Map.toList mp)
pure $ fold allSets

-- | Respond to an 'AddressChangeRequest' for a future slot.
waitForAddressChange :: AddressChangeRequest -> BlockchainEnv -> STM AddressChangeResponse
waitForAddressChange AddressChangeRequest{acreqSlot, acreqAddress} b@BlockchainEnv{beTxIndex} = do
_ <- awaitSlot (succ acreqSlot) b
Expand Down
83 changes: 43 additions & 40 deletions plutus-pab/src/Plutus/PAB/Webserver/Handler.hs
View file
Expand Up @@ -22,46 +22,48 @@ module Plutus.PAB.Webserver.Handler
, invokeEndpoint
) where

import Cardano.Metadata.Types (MetadataEffect, QueryResult, Subject,
SubjectProperties (SubjectProperties), batchQuery)
import qualified Cardano.Metadata.Types as Metadata
import Control.Concurrent.STM (atomically)
import Control.Monad.Freer (Eff, LastMember, Member, type (~>))
import Control.Monad.Freer.Error (Error, throwError)
import Control.Monad.Freer.Extras.Log (LogMsg, logInfo)
import Control.Monad.Freer.Reader (Reader, ask)
import Control.Monad.IO.Class (MonadIO (..))
import qualified Data.Aeson as JSON
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Text (Text)
import Data.Text.Prettyprint.Doc (Pretty (..), defaultLayoutOptions, layoutPretty)
import Data.Text.Prettyprint.Doc.Render.Text (renderStrict)
import qualified Data.UUID as UUID
import Eventful (streamEventEvent)
import Language.Plutus.Contract.Effects.ExposeEndpoint (EndpointDescription (EndpointDescription))
import Ledger (pubKeyHash)
import Ledger.Blockchain (Blockchain)
import Plutus.PAB.Core (runGlobalQuery)
import qualified Plutus.PAB.Core as Core
import qualified Plutus.PAB.Core.ContractInstance as Instance
import Plutus.PAB.Core.ContractInstance.STM (InstancesState, callEndpointOnInstance)
import Plutus.PAB.Effects.Contract (ContractEffect, exportSchema)
import Plutus.PAB.Effects.EventLog (EventLogEffect)
import Plutus.PAB.Effects.UUID (UUIDEffect)
import Plutus.PAB.Events (ChainEvent, ContractInstanceId (ContractInstanceId),
ContractInstanceState (ContractInstanceState),
csContractDefinition)
import qualified Plutus.PAB.Monitoring.PABLogMsg as LM
import Plutus.PAB.ParseStringifiedJSON (UnStringifyJSONLog, parseStringifiedJSON)
import qualified Plutus.PAB.Query as Query
import Cardano.Metadata.Types (MetadataEffect, QueryResult, Subject,
SubjectProperties (SubjectProperties), batchQuery)
import qualified Cardano.Metadata.Types as Metadata
import Control.Concurrent.STM (atomically)
import Control.Monad.Freer (Eff, LastMember, Member, type (~>))
import Control.Monad.Freer.Error (Error, throwError)
import Control.Monad.Freer.Extras.Log (LogMsg, logInfo, logWarn)
import Control.Monad.Freer.Reader (Reader, ask)
import Control.Monad.IO.Class (MonadIO (..))
import qualified Data.Aeson as JSON
import Data.Foldable (traverse_)
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Text (Text)
import Data.Text.Prettyprint.Doc (Pretty (..), defaultLayoutOptions, layoutPretty)
import Data.Text.Prettyprint.Doc.Render.Text (renderStrict)
import qualified Data.UUID as UUID
import Eventful (streamEventEvent)
import Language.Plutus.Contract.Effects.ExposeEndpoint (EndpointDescription (EndpointDescription))
import Ledger (pubKeyHash)
import Ledger.Blockchain (Blockchain)
import Plutus.PAB.Core (runGlobalQuery)
import qualified Plutus.PAB.Core as Core
import qualified Plutus.PAB.Core.ContractInstance as Instance
import qualified Plutus.PAB.Core.ContractInstance.RequestHandlers as LM
import Plutus.PAB.Core.ContractInstance.STM (InstancesState, callEndpointOnInstance)
import Plutus.PAB.Effects.Contract (ContractEffect, exportSchema)
import Plutus.PAB.Effects.EventLog (EventLogEffect)
import Plutus.PAB.Effects.UUID (UUIDEffect)
import Plutus.PAB.Events (ChainEvent, ContractInstanceId (ContractInstanceId),
ContractInstanceState (ContractInstanceState),
csContractDefinition)
import qualified Plutus.PAB.Monitoring.PABLogMsg as LM
import Plutus.PAB.ParseStringifiedJSON (UnStringifyJSONLog, parseStringifiedJSON)
import qualified Plutus.PAB.Query as Query
import Plutus.PAB.Types
import Plutus.PAB.Webserver.Types
import Servant ((:<|>) ((:<|>)))
import Wallet.Effects (ChainIndexEffect, confirmedBlocks)
import Wallet.Emulator.Wallet (Wallet (Wallet), walletPubKey)
import qualified Wallet.Rollup as Rollup
import Servant ((:<|>) ((:<|>)))
import Wallet.Effects (ChainIndexEffect, confirmedBlocks)
import Wallet.Emulator.Wallet (Wallet (Wallet), walletPubKey)
import qualified Wallet.Rollup as Rollup

healthcheck :: Monad m => m ()
healthcheck = pure ()
Expand Down Expand Up @@ -205,12 +207,14 @@ invokeEndpoint (EndpointDescription endpointDescription) payload contractId = do
newState
getContractInstanceState contractId

-- | Call an endpoint using the STM-based contract runner.
invokeEndpointSTM ::
forall t m effs.
( Member (EventLogEffect (ChainEvent t)) effs
, Member (LogMsg LM.ContractExeLogMsg) effs
, Member (Error PABError) effs
, Member (Reader InstancesState) effs
, Member (LogMsg (Instance.ContractInstanceMsg t)) effs
, LastMember m effs
, MonadIO m
)
Expand All @@ -221,9 +225,8 @@ invokeEndpointSTM ::
invokeEndpointSTM d@(EndpointDescription endpointDescription) payload contractId = do
logInfo $ LM.InvokingEndpoint endpointDescription payload
inst <- ask @InstancesState
liftIO $ putStrLn "invokeEndpointSTM: Invoking endpoint"
response <- liftIO $ atomically $ callEndpointOnInstance inst d payload contractId
liftIO $ putStrLn $ "invokeEndpointSTM response: " <> show response
traverse_ (logWarn @(Instance.ContractInstanceMsg t) . LM.NotificationFailed) response
getContractInstanceState contractId

parseContractId ::
Expand Down

0 comments on commit 27c6c5f

Please sign in to comment.