diff --git a/bot-plutus-interface.cabal b/bot-plutus-interface.cabal index f757f09b..c1dff49d 100644 --- a/bot-plutus-interface.cabal +++ b/bot-plutus-interface.cabal @@ -103,7 +103,9 @@ library , data-default , data-default-class , directory + , prettyprinter , either + , vector , filepath , freer-extras , freer-simple @@ -173,6 +175,7 @@ test-suite bot-plutus-interface-test , data-default-class , either , extra + , prettyprinter , filepath , freer-extras , freer-simple diff --git a/flake.lock b/flake.lock index 6a02e523..ec2ea2fe 100644 --- a/flake.lock +++ b/flake.lock @@ -460,11 +460,11 @@ "hackage_2": { "flake": false, "locked": { - "lastModified": 1644887696, - "narHash": "sha256-o4gltv4npUl7+1gEQIcrRqZniwqC9kK8QsPaftlrawc=", + "lastModified": 1652663624, + "narHash": "sha256-WeZYALZ6wjXJaMi0ZiSLq5A/ybvES8vN3zPozUgzkFs=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "6ff64aa49b88e75dd6e0bbd2823c2a92c9174fa5", + "rev": "70c6780e617190a1ecc26bd004ece9ea67dcc260", "type": "github" }, "original": { @@ -484,6 +484,7 @@ "ghc-8.6.5-iohk": "ghc-8.6.5-iohk_2", "hackage": "hackage_2", "hpc-coveralls": "hpc-coveralls_2", + "hydra": "hydra", "nix-tools": "nix-tools_2", "nixpkgs": [ "haskell-nix", @@ -497,15 +498,15 @@ "stackage": "stackage_2" }, "locked": { - "lastModified": 1644944726, - "narHash": "sha256-jJWdP/3Ne1y1akC3m9rSO5ItRoBc4UTdVQZBCuPmmrM=", - "owner": "L-as", + "lastModified": 1652698457, + "narHash": "sha256-o9UvhU9QwdzXTFOnRB+MTQ0+fP5DblInxHoXqN6DplA=", + "owner": "mlabs-haskell", "repo": "haskell.nix", - "rev": "45c583b5580c130487eb5a342679f0bdbc2b23fc", + "rev": "269936645c92aa74b8b0695e96a1c92fd108f8aa", "type": "github" }, "original": { - "owner": "L-as", + "owner": "mlabs-haskell", "repo": "haskell.nix", "type": "github" } @@ -578,6 +579,29 @@ "type": "github" } }, + "hydra": { + "inputs": { + "nix": "nix", + "nixpkgs": [ + "haskell-nix", + "hydra", + "nix", + "nixpkgs" + ] + }, + "locked": { + "lastModified": 1646878427, + "narHash": "sha256-KtbrofMtN8GlM7D+n90kixr7QpSlVmdN+vK5CA/aRzc=", + "owner": "NixOS", + "repo": "hydra", + "rev": "28b682b85b7efc5cf7974065792a1f22203a5927", + "type": "github" + }, + "original": { + "id": "hydra", + "type": "indirect" + } + }, "iohk-monitoring-framework": { "flake": false, "locked": { @@ -632,6 +656,43 @@ "type": "github" } }, + "lowdown-src": { + "flake": false, + "locked": { + "lastModified": 1633514407, + "narHash": "sha256-Dw32tiMjdK9t3ETl5fzGrutQTzh2rufgZV4A/BbxuD4=", + "owner": "kristapsdz", + "repo": "lowdown", + "rev": "d2c2b44ff6c27b936ec27358a2653caaef8f73b8", + "type": "github" + }, + "original": { + "owner": "kristapsdz", + "repo": "lowdown", + "type": "github" + } + }, + "nix": { + "inputs": { + "lowdown-src": "lowdown-src", + "nixpkgs": "nixpkgs", + "nixpkgs-regression": "nixpkgs-regression" + }, + "locked": { + "lastModified": 1643066034, + "narHash": "sha256-xEPeMcNJVOeZtoN+d+aRwolpW8mFSEQx76HTRdlhPhg=", + "owner": "NixOS", + "repo": "nix", + "rev": "a1cd7e58606a41fcf62bf8637804cf8306f17f62", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "2.6.0", + "repo": "nix", + "type": "github" + } + }, "nix-tools": { "flake": false, "locked": { @@ -651,11 +712,11 @@ "nix-tools_2": { "flake": false, "locked": { - "lastModified": 1644395812, - "narHash": "sha256-BVFk/BEsTLq5MMZvdy3ZYHKfaS3dHrsKh4+tb5t5b58=", + "lastModified": 1649424170, + "narHash": "sha256-XgKXWispvv5RCvZzPb+p7e6Hy3LMuRjafKMl7kXzxGw=", "owner": "input-output-hk", "repo": "nix-tools", - "rev": "d847c63b99bbec78bf83be2a61dc9f09b8a9ccc1", + "rev": "e109c94016e3b6e0db7ed413c793e2d4bdb24aa7", "type": "github" }, "original": { @@ -664,6 +725,21 @@ "type": "github" } }, + "nixpkgs": { + "locked": { + "lastModified": 1632864508, + "narHash": "sha256-d127FIvGR41XbVRDPVvozUPQ/uRHbHwvfyKHwEt5xFM=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "82891b5e2c2359d7e58d08849e4c89511ab94234", + "type": "github" + }, + "original": { + "id": "nixpkgs", + "ref": "nixos-21.05-small", + "type": "indirect" + } + }, "nixpkgs-2003": { "locked": { "lastModified": 1620055814, @@ -714,11 +790,11 @@ }, "nixpkgs-2105_2": { "locked": { - "lastModified": 1642244250, - "narHash": "sha256-vWpUEqQdVP4srj+/YLJRTN9vjpTs4je0cdWKXPbDItc=", + "lastModified": 1645296114, + "narHash": "sha256-y53N7TyIkXsjMpOG7RhvqJFGDacLs9HlyHeSTBioqYU=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "0fd9ee1aa36ce865ad273f4f07fdc093adeb5c00", + "rev": "530a53dcbc9437363471167a5e4762c5fcfa34a1", "type": "github" }, "original": { @@ -746,11 +822,11 @@ }, "nixpkgs-2111_2": { "locked": { - "lastModified": 1644510859, - "narHash": "sha256-xjpVvL5ecbyi0vxtVl/Fh9bwGlMbw3S06zE5nUzFB8A=", + "lastModified": 1648744337, + "narHash": "sha256-bYe1dFJAXovjqiaPKrmAbSBEK5KUkgwVaZcTbSoJ7hg=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "0d1d5d7e3679fec9d07f2eb804d9f9fdb98378d3", + "rev": "0a58eebd8ec65ffdef2ce9562784123a73922052", "type": "github" }, "original": { @@ -760,6 +836,21 @@ "type": "github" } }, + "nixpkgs-regression": { + "locked": { + "lastModified": 1643052045, + "narHash": "sha256-uGJ0VXIhWKGXxkeNnq4TvV3CIOkUJ3PAoLZ3HMzNVMw=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2", + "type": "github" + }, + "original": { + "id": "nixpkgs", + "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2", + "type": "indirect" + } + }, "nixpkgs-unstable": { "locked": { "lastModified": 1635295995, @@ -778,11 +869,11 @@ }, "nixpkgs-unstable_2": { "locked": { - "lastModified": 1644486793, - "narHash": "sha256-EeijR4guVHgVv+JpOX3cQO+1XdrkJfGmiJ9XVsVU530=", + "lastModified": 1648219316, + "narHash": "sha256-Ctij+dOi0ZZIfX5eMhgwugfvB+WZSrvVNAyAuANOsnQ=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "1882c6b7368fd284ad01b0a5b5601ef136321292", + "rev": "30d3d79b7d3607d56546dd2a6b49e156ba0ec634", "type": "github" }, "original": { @@ -976,11 +1067,11 @@ "stackage_2": { "flake": false, "locked": { - "lastModified": 1644887829, - "narHash": "sha256-tjUXJpqB7MMnqM4FF5cdtZipfratUcTKRQVA6F77sEQ=", + "lastModified": 1652577319, + "narHash": "sha256-zZxCo7vIdyjZueJD3VoR7YImsS54dRhqqVRcsLqUBP0=", "owner": "input-output-hk", "repo": "stackage.nix", - "rev": "db8bdef6588cf4f38e6069075ba76f0024381f68", + "rev": "49dfbc9cbf38cbf8180a432fcd6d390326c74fba", "type": "github" }, "original": { diff --git a/flake.nix b/flake.nix index 05a02f5d..e3ddaf51 100644 --- a/flake.nix +++ b/flake.nix @@ -2,7 +2,7 @@ description = "bot-plutus-interface"; inputs = { - haskell-nix.url = "github:L-as/haskell.nix"; + haskell-nix.url = "github:mlabs-haskell/haskell.nix"; nixpkgs.follows = "haskell-nix/nixpkgs-unstable"; diff --git a/src/BotPlutusInterface/Balance.hs b/src/BotPlutusInterface/Balance.hs index 6f9bec01..b38c5683 100644 --- a/src/BotPlutusInterface/Balance.hs +++ b/src/BotPlutusInterface/Balance.hs @@ -7,7 +7,7 @@ module BotPlutusInterface.Balance ( ) where import BotPlutusInterface.CardanoCLI qualified as CardanoCLI -import BotPlutusInterface.Effects (PABEffect, createDirectoryIfMissingCLI, printLog) +import BotPlutusInterface.Effects (PABEffect, createDirectoryIfMissingCLI, printBpiLog) import BotPlutusInterface.Files (DummyPrivKey, unDummyPrivateKey) import BotPlutusInterface.Files qualified as Files import BotPlutusInterface.Types (LogLevel (Debug), PABConfig) @@ -60,6 +60,7 @@ import Plutus.V1.Ledger.Api ( ) import BotPlutusInterface.BodyBuilder qualified as BodyBuilder +import Prettyprinter (pretty, viaShow, (<+>)) import Prelude {- | Collect necessary tx inputs and collaterals, add minimum lovelace values and balance non ada @@ -86,7 +87,7 @@ balanceTxIO pabConf ownPkh unbalancedTx = (unBalancedTxValidityTimeRange unbalancedTx) (unBalancedTxTx unbalancedTx) - lift $ printLog @w Debug $ show utxoIndex + lift $ printBpiLog @w Debug $ viaShow utxoIndex -- We need this folder on the CLI machine, which may not be the local machine lift $ createDirectoryIfMissingCLI @w False (Text.unpack pabConf.pcTxFileDir) @@ -130,7 +131,7 @@ balanceTxIO pabConf ownPkh unbalancedTx = let minUtxos = prevMinUtxos ++ nextMinUtxos - lift $ printLog @w Debug $ "Min utxos: " ++ show minUtxos + lift $ printBpiLog @w Debug $ "Min utxos:" <+> pretty minUtxos -- Calculate fees by pre-balancing the tx, building it, and running the CLI on result txWithoutFees <- @@ -142,7 +143,7 @@ balanceTxIO pabConf ownPkh unbalancedTx = let fees = nonBudgettedFees + getBudgetPrice (getExecutionUnitPrices pabConf) exBudget - lift $ printLog @w Debug $ "Fees: " ++ show fees + lift $ printBpiLog @w Debug $ "Fees:" <+> pretty fees -- Rebalance the initial tx with the above fees balancedTx <- hoistEither $ balanceTxStep minUtxos utxoIndex changeAddr $ tx `withFee` fees diff --git a/src/BotPlutusInterface/Contract.hs b/src/BotPlutusInterface/Contract.hs index 6749c663..17119cbd 100644 --- a/src/BotPlutusInterface/Contract.hs +++ b/src/BotPlutusInterface/Contract.hs @@ -1,5 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -Wno-orphans #-} module BotPlutusInterface.Contract (runContract, handleContract) where @@ -12,9 +13,10 @@ import BotPlutusInterface.Effects ( callCommand, createDirectoryIfMissing, estimateBudget, + handleContractLog, handlePABEffect, logToContract, - printLog, + printBpiLog, queryChainIndex, readFileTextEnvelope, saveBudget, @@ -34,19 +36,20 @@ import Control.Lens (preview, (^.)) import Control.Monad (join, void, when) import Control.Monad.Freer (Eff, Member, interpret, reinterpret, runM, subsume, type (~>)) import Control.Monad.Freer.Error (runError) -import Control.Monad.Freer.Extras.Log (handleLogIgnore) import Control.Monad.Freer.Extras.Modify (raiseEnd) import Control.Monad.Freer.Writer (Writer (Tell)) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Either (EitherT, eitherT, firstEitherT, newEitherT) -import Data.Aeson (ToJSON, Value) +import Data.Aeson (ToJSON, Value (Array, Bool, Null, Number, Object, String)) import Data.Aeson.Extras (encodeByteString) import Data.Either (fromRight) +import Data.HashMap.Strict qualified as HM import Data.Kind (Type) import Data.Map qualified as Map import Data.Row (Row) import Data.Text (Text) import Data.Text qualified as Text +import Data.Vector qualified as V import Ledger (POSIXTime) import Ledger qualified import Ledger.Address (PaymentPubKeyHash (PaymentPubKeyHash)) @@ -69,6 +72,8 @@ import Plutus.Contract.Effects ( import Plutus.Contract.Resumable (Resumable (..)) import Plutus.Contract.Types (Contract (..), ContractEffs) import PlutusTx.Builtins (fromBuiltin) +import Prettyprinter (Pretty (pretty), (<+>)) +import Prettyprinter qualified as PP import Wallet.Emulator.Error (WalletAPIError (..)) import Prelude @@ -92,10 +97,29 @@ handleContract contractEnv = . handleResumable contractEnv . handleCheckpointIgnore . handleWriter - . handleLogIgnore @Value + . handleContractLog @w . runError . raiseEnd +instance Pretty Value where + pretty (String s) = pretty s + pretty (Number n) = pretty $ show n + pretty (Bool b) = pretty b + pretty (Array arr) = PP.list $ pretty <$> V.toList arr + pretty (Object obj) = + PP.group + . PP.encloseSep (PP.flatAlt "{ " "{") (PP.flatAlt " }" "}") ", " + . map + ( \(k, v) -> + PP.hang 2 $ + PP.sep + [ pretty k <+> ": " + , pretty v + ] + ) + $ HM.toList obj + pretty Null = "null" + handleWriter :: forall (w :: Type) (effs :: [Type -> Type]). (ToJSON w, Monoid w) => @@ -140,7 +164,7 @@ handlePABReq :: PABReq -> Eff effs PABResp handlePABReq contractEnv req = do - printLog @w Debug $ show req + printBpiLog @w Debug $ pretty req resp <- case req of ---------------------- -- Handled requests -- @@ -176,7 +200,7 @@ handlePABReq contractEnv req = do -- YieldUnbalancedTxReq UnbalancedTx unsupported -> error ("Unsupported PAB effect: " ++ show unsupported) - printLog @w Debug $ show resp + printBpiLog @w Debug $ pretty resp pure resp awaitTxStatusChange :: @@ -193,7 +217,7 @@ awaitTxStatusChange contractEnv txId = do case mTx of Nothing -> pure Unknown Just txState -> do - printLog @w Debug $ "Found transaction in node, waiting " ++ show chainConstant ++ " blocks for it to settle." + printBpiLog @w Debug $ "Found transaction in node, waiting" <+> pretty chainConstant <+> " blocks for it to settle." awaitNBlocks @w contractEnv (chainConstant + 1) -- Check if the tx is still present in chain-index, in case of a rollback -- we might not find it anymore. @@ -268,10 +292,10 @@ writeBalancedTx contractEnv (Right tx) = do if signable then newEitherT $ CardanoCLI.signTx @w pabConf tx requiredSigners else - lift . printLog @w Warn . Text.unpack . Text.unlines $ + lift . printBpiLog @w Warn . PP.vsep $ [ "Not all required signatures have signing key files. Please sign and submit the tx manually:" - , "Tx file: " <> Files.txFilePath pabConf "raw" (Tx.txId tx) - , "Signatories (pkh): " <> Text.unwords (map pkhToText requiredSigners) + , "Tx file:" <+> pretty (Files.txFilePath pabConf "raw" (Tx.txId tx)) + , "Signatories (pkh):" <+> pretty (Text.unwords (map pkhToText requiredSigners)) ] when (pabConf.pcCollectStats && signable) $ diff --git a/src/BotPlutusInterface/Effects.hs b/src/BotPlutusInterface/Effects.hs index 8e271c95..0f54bae6 100644 --- a/src/BotPlutusInterface/Effects.hs +++ b/src/BotPlutusInterface/Effects.hs @@ -14,6 +14,8 @@ module BotPlutusInterface.Effects ( uploadDir, updateInstanceState, printLog, + printBpiLog, + handleContractLog, logToContract, readFileTextEnvelope, writeFileJSON, @@ -31,6 +33,7 @@ import BotPlutusInterface.Types ( CLILocation (..), ContractEnvironment, ContractState (ContractState), + LogContext (BpiLog, ContractLog), LogLevel (..), TxBudget, TxFile, @@ -40,8 +43,11 @@ import Cardano.Api (AsType, FileError (FileIOError), HasTextEnvelope, TextEnvelo import Cardano.Api qualified import Control.Concurrent qualified as Concurrent import Control.Concurrent.STM (atomically, modifyTVar, modifyTVar') +import Control.Lens ((^.)) import Control.Monad (void, when) -import Control.Monad.Freer (Eff, LastMember, Member, interpretM, send, type (~>)) +import Control.Monad.Freer (Eff, LastMember, Member, interpretM, reinterpret, send, subsume, type (~>)) +import Control.Monad.Freer.Extras (LogMsg (LMessage)) +import Control.Monad.Freer.Extras qualified as Freer import Control.Monad.Trans.Except.Extra (handleIOExceptT, runExceptT) import Data.Aeson (ToJSON) import Data.Aeson qualified as JSON @@ -56,6 +62,9 @@ import Ledger qualified import Plutus.Contract.Effects (ChainIndexQuery, ChainIndexResponse) import Plutus.PAB.Core.ContractInstance.STM (Activity) import PlutusTx.Builtins.Internal (BuiltinByteString (BuiltinByteString)) +import Prettyprinter (Pretty (pretty), defaultLayoutOptions, layoutPretty, (<+>)) +import Prettyprinter qualified as PP +import Prettyprinter.Render.String qualified as Render import System.Directory qualified as Directory import System.Exit (ExitCode (ExitFailure, ExitSuccess)) import System.Process (readProcess, readProcessWithExitCode) @@ -75,7 +84,7 @@ data PABEffect (w :: Type) (r :: Type) where CreateDirectoryIfMissing :: Bool -> FilePath -> PABEffect w () -- Same as above but creates folder on the CLI machine, be that local or remote. CreateDirectoryIfMissingCLI :: Bool -> FilePath -> PABEffect w () - PrintLog :: LogLevel -> String -> PABEffect w () + PrintLog :: LogContext -> LogLevel -> PP.Doc () -> PABEffect w () UpdateInstanceState :: Activity -> PABEffect w () LogToContract :: (ToJSON w, Monoid w) => w -> PABEffect w () ThreadDelay :: Int -> PABEffect w () @@ -117,7 +126,7 @@ handlePABEffect contractEnv = case contractEnv.cePABConfig.pcCliLocation of Local -> Directory.createDirectoryIfMissing createParents filePath Remote ipAddr -> createDirectoryIfMissingRemote ipAddr createParents filePath - PrintLog logLevel txt -> printLog' contractEnv.cePABConfig.pcLogLevel logLevel txt + PrintLog logCtx logLevel txt -> printLog' contractEnv.cePABConfig.pcLogLevel logCtx logLevel txt UpdateInstanceState s -> do atomically $ modifyTVar contractEnv.ceContractState $ @@ -148,9 +157,34 @@ handlePABEffect contractEnv = SaveBudget txId exBudget -> saveBudgetImpl contractEnv txId exBudget ) -printLog' :: LogLevel -> LogLevel -> String -> IO () -printLog' logLevelSetting msgLogLvl msg = - when (logLevelSetting >= msgLogLvl) $ putStrLn msg +printLog' :: LogLevel -> LogContext -> LogLevel -> PP.Doc () -> IO () +printLog' logLevelSetting msgCtx msgLogLvl msg = + when (logLevelSetting >= msgLogLvl) $ putStrLn target + where + target = + Render.renderString . layoutPretty defaultLayoutOptions $ + pretty msgCtx <+> pretty msgLogLvl <+> msg + +-- | Reinterpret contract logs to be handled by PABEffect later down the line. +handleContractLog :: forall w a effs. Member (PABEffect w) effs => Pretty a => Eff (LogMsg a ': effs) ~> Eff effs +handleContractLog x = subsume $ handleContractLogInternal @w x + +handleContractLogInternal :: forall w a effs. Pretty a => Eff (LogMsg a ': effs) ~> Eff (PABEffect w ': effs) +handleContractLogInternal = reinterpret $ \case + LMessage logMsg -> + let msgContent = logMsg ^. Freer.logMessageContent + msgLogLevel = toNativeLogLevel (logMsg ^. Freer.logLevel) + msgPretty = pretty msgContent + in printLog @w ContractLog msgLogLevel msgPretty + where + toNativeLogLevel Freer.Debug = Debug + toNativeLogLevel Freer.Info = Info + toNativeLogLevel Freer.Notice = Notice + toNativeLogLevel Freer.Warning = Warn + toNativeLogLevel Freer.Error = Error + toNativeLogLevel Freer.Critical = Error + toNativeLogLevel Freer.Alert = Error + toNativeLogLevel Freer.Emergency = Error callLocalCommand :: forall (a :: Type). ShellArgs a -> IO (Either Text a) callLocalCommand ShellArgs {cmdName, cmdArgs, cmdOutParser} = @@ -221,12 +255,21 @@ createDirectoryIfMissingCLI :: createDirectoryIfMissingCLI createParents path = send @(PABEffect w) $ CreateDirectoryIfMissingCLI createParents path printLog :: + forall (w :: Type) (effs :: [Type -> Type]). + Member (PABEffect w) effs => + LogContext -> + LogLevel -> + PP.Doc () -> + Eff effs () +printLog logCtx logLevel msg = send @(PABEffect w) $ PrintLog logCtx logLevel msg + +printBpiLog :: forall (w :: Type) (effs :: [Type -> Type]). Member (PABEffect w) effs => LogLevel -> - String -> + PP.Doc () -> Eff effs () -printLog logLevel msg = send @(PABEffect w) $ PrintLog logLevel msg +printBpiLog = printLog @w BpiLog updateInstanceState :: forall (w :: Type) (effs :: [Type -> Type]). Member (PABEffect w) effs => Activity -> Eff effs () diff --git a/src/BotPlutusInterface/Types.hs b/src/BotPlutusInterface/Types.hs index cc52aadd..9dc1d97a 100644 --- a/src/BotPlutusInterface/Types.hs +++ b/src/BotPlutusInterface/Types.hs @@ -7,6 +7,7 @@ module BotPlutusInterface.Types ( CLILocation (..), AppState (AppState), LogLevel (..), + LogContext (..), ContractEnvironment (..), Tip (Tip, epoch, hash, slot, block, era, syncProgress), ContractState (..), @@ -53,6 +54,7 @@ import Plutus.PAB.Effects.Contract.Builtin ( SomeBuiltin (SomeBuiltin), endpointsToSchemas, ) +import Prettyprinter (Pretty (pretty)) import Servant.Client (BaseUrl (BaseUrl), Scheme (Http)) import Wallet.Types (ContractInstanceId (..)) import Prelude @@ -184,7 +186,23 @@ data CLILocation = Local | Remote Text deriving stock (Show, Eq) data LogLevel = Error | Warn | Notice | Info | Debug - deriving stock (Eq, Ord, Show) + deriving stock (Bounded, Enum, Eq, Ord, Show) + +instance Pretty LogLevel where + pretty = \case + Debug -> "[DEBUG]" + Info -> "[INFO]" + Notice -> "[NOTICE]" + Warn -> "[WARNING]" + Error -> "[ERROR]" + +data LogContext = BpiLog | ContractLog + deriving stock (Bounded, Enum, Eq, Ord, Show) + +instance Pretty LogContext where + pretty = \case + BpiLog -> "[BPI]" + ContractLog -> "[CONTRACT]" instance Default PABConfig where def = diff --git a/test/Spec/MockContract.hs b/test/Spec/MockContract.hs index 56ee5957..fb75a369 100644 --- a/test/Spec/MockContract.hs +++ b/test/Spec/MockContract.hs @@ -55,6 +55,7 @@ import BotPlutusInterface.Types ( BudgetEstimationError, ContractEnvironment (..), ContractState (ContractState, csActivity, csObservableState), + LogContext, LogLevel (..), PABConfig (..), TxBudget (TxBudget), @@ -125,6 +126,7 @@ import Plutus.PAB.Core.ContractInstance.STM (Activity (Active)) import Plutus.V1.Ledger.Credential (Credential (PubKeyCredential)) import PlutusTx.Builtins (fromBuiltin) import PlutusTx.Builtins.Internal (BuiltinByteString (BuiltinByteString)) +import Prettyprinter qualified as PP import System.IO.Unsafe (unsafePerformIO) import Text.Read (readMaybe) import Wallet.Types (ContractInstanceId (ContractInstanceId)) @@ -208,7 +210,7 @@ data MockContractState w = MockContractState , _commandHistory :: [Text] , _instanceUpdateHistory :: [Activity] , _observableState :: w - , _logHistory :: [(LogLevel, String)] + , _logHistory :: [(LogContext, LogLevel, PP.Doc ())] , _contractEnv :: ContractEnvironment w , _utxos :: [(TxOutRef, TxOut)] , _tip :: Tip @@ -292,7 +294,7 @@ runPABEffectPure initState req = mockCreateDirectoryIfMissing createParents filePath go (CreateDirectoryIfMissingCLI createParents filePath) = mockCreateDirectoryIfMissing createParents filePath - go (PrintLog logLevel msg) = mockPrintLog logLevel msg + go (PrintLog logCtx logLevel msg) = mockPrintLog logCtx logLevel msg go (UpdateInstanceState msg) = mockUpdateInstanceState msg go (LogToContract msg) = mockLogToContract msg go (ThreadDelay microseconds) = mockThreadDelay microseconds @@ -454,9 +456,9 @@ valueToUtxoOut = mockCreateDirectoryIfMissing :: forall (w :: Type). Bool -> FilePath -> MockContract w () mockCreateDirectoryIfMissing _ _ = pure () -mockPrintLog :: forall (w :: Type). LogLevel -> String -> MockContract w () -mockPrintLog logLevel msg = - modify @(MockContractState w) (logHistory %~ ((logLevel, msg) <|)) +mockPrintLog :: forall (w :: Type). LogContext -> LogLevel -> PP.Doc () -> MockContract w () +mockPrintLog logCtx logLevel msg = + modify @(MockContractState w) (logHistory %~ ((logCtx, logLevel, msg) <|)) mockUpdateInstanceState :: forall (w :: Type). Activity -> MockContract w () mockUpdateInstanceState msg =