diff --git a/src/BotPlutusInterface/Balance.hs b/src/BotPlutusInterface/Balance.hs index 6517976b..675dc9ae 100644 --- a/src/BotPlutusInterface/Balance.hs +++ b/src/BotPlutusInterface/Balance.hs @@ -23,7 +23,14 @@ import BotPlutusInterface.Effects ( ) import BotPlutusInterface.Files (DummyPrivKey, unDummyPrivateKey) import BotPlutusInterface.Files qualified as Files -import BotPlutusInterface.Types (CollateralUtxo, LogLevel (Debug), PABConfig, collateralTxOutRef) +import BotPlutusInterface.Types ( + CollateralUtxo (collateralTxOutRef), + LogLevel (Debug), + LogType (TxBalancingLog), + PABConfig, + collateralTxOutRef, + ) + import Cardano.Api (ExecutionUnitPrices (ExecutionUnitPrices)) import Cardano.Api.Shelley (ProtocolParameters (protocolParamPrices)) import Control.Monad (foldM, void, zipWithM) @@ -121,7 +128,7 @@ balanceTxIO' balanceCfg pabConf ownPkh unbalancedTx = requiredSigs :: [PubKeyHash] requiredSigs = map Ledger.unPaymentPubKeyHash $ Map.keys (unBalancedTxRequiredSignatories unbalancedTx) - lift $ printBpiLog @w Debug $ viaShow utxoIndex + lift $ printBpiLog @w (Debug [TxBalancingLog]) $ viaShow utxoIndex -- We need this folder on the CLI machine, which may not be the local machine lift $ createDirectoryIfMissingCLI @w False (Text.unpack "pcTxFileDir") @@ -182,7 +189,7 @@ balanceTxIO' balanceCfg pabConf ownPkh unbalancedTx = let minUtxos = prevMinUtxos ++ nextMinUtxos - lift $ printBpiLog @w Debug $ "Min utxos:" <+> pretty minUtxos + lift $ printBpiLog @w (Debug [TxBalancingLog]) $ "Min utxos:" <+> pretty minUtxos -- Calculate fees by pre-balancing the tx, building it, and running the CLI on result txWithoutFees <- @@ -194,7 +201,7 @@ balanceTxIO' balanceCfg pabConf ownPkh unbalancedTx = let fees = nonBudgettedFees + getBudgetPrice (getExecutionUnitPrices pabConf) exBudget - lift $ printBpiLog @w Debug $ "Fees:" <+> pretty fees + lift $ printBpiLog @w (Debug [TxBalancingLog]) $ "Fees:" <+> pretty fees -- Rebalance the initial tx with the above fees balancedTx <- hoistEither $ balanceTxStep balanceCfg minUtxos utxoIndex changeAddr $ tx `withFee` fees diff --git a/src/BotPlutusInterface/Config.hs b/src/BotPlutusInterface/Config.hs index f6485eb4..7d515016 100644 --- a/src/BotPlutusInterface/Config.hs +++ b/src/BotPlutusInterface/Config.hs @@ -17,6 +17,7 @@ import BotPlutusInterface.Effects ( import BotPlutusInterface.Types ( CLILocation (..), LogLevel (..), + LogType (AnyLog), PABConfig (..), TxStatusPolling (TxStatusPolling, spBlocksTimeOut, spInterval), ) @@ -75,11 +76,11 @@ instance ToValue LogLevel where logLevelSpec :: ValueSpec LogLevel logLevelSpec = - Error <$ atomSpec "error" - Warn <$ atomSpec "warn" - Notice <$ atomSpec "notice" - Info <$ atomSpec "info" - Debug <$ atomSpec "debug" + Error [AnyLog] <$ atomSpec "error" + Warn [AnyLog] <$ atomSpec "warn" + Notice [AnyLog] <$ atomSpec "notice" + Info [AnyLog] <$ atomSpec "info" + Debug [AnyLog] <$ atomSpec "debug" instance ToValue TxStatusPolling where toValue (TxStatusPolling interval timeout) = diff --git a/src/BotPlutusInterface/Contract.hs b/src/BotPlutusInterface/Contract.hs index 4560bef4..70f4af97 100644 --- a/src/BotPlutusInterface/Contract.hs +++ b/src/BotPlutusInterface/Contract.hs @@ -35,6 +35,7 @@ import BotPlutusInterface.Types ( CollateralUtxo (CollateralUtxo), ContractEnvironment (..), LogLevel (Debug, Notice, Warn), + LogType (CollateralLog, PABLog), Tip (block, slot), TxFile (Signed), collateralValue, @@ -174,7 +175,7 @@ handlePABReq :: PABReq -> Eff effs PABResp handlePABReq contractEnv req = do - printBpiLog @w Debug $ pretty req + printBpiLog @w (Debug [PABLog]) $ pretty req resp <- case req of ---------------------- -- Handled requests -- @@ -208,7 +209,7 @@ handlePABReq contractEnv req = do -- YieldUnbalancedTxReq UnbalancedTx unsupported -> error ("Unsupported PAB effect: " ++ show unsupported) - printBpiLog @w Debug $ pretty resp + printBpiLog @w (Debug [PABLog]) $ pretty resp pure resp {- | Await till transaction status change to something from `Unknown`. @@ -227,7 +228,7 @@ awaitTxStatusChange :: Eff effs TxStatus awaitTxStatusChange contractEnv txId = do checkStartedBlock <- currentBlock contractEnv - printBpiLog @w Debug $ pretty $ "Awaiting status change for " ++ show txId + printBpiLog @w (Debug [PABLog]) $ pretty $ "Awaiting status change for " ++ show txId let txStatusPolling = contractEnv.cePABConfig.pcTxStatusPolling pollInterval = fromIntegral $ txStatusPolling.spInterval @@ -276,7 +277,7 @@ awaitTxStatusChange contractEnv txId = do pure . Just $ fromTx blk tx Nothing -> pure Nothing - logDebug = printBpiLog @w Debug . pretty + logDebug = printBpiLog @w (Debug [PABLog]) . pretty -- | This will FULLY balance a transaction balanceTx :: @@ -339,7 +340,7 @@ writeBalancedTx contractEnv (Right tx) = do if signable then newEitherT $ CardanoCLI.signTx @w pabConf tx requiredSigners else - lift . printBpiLog @w Warn . PP.vsep $ + lift . printBpiLog @w (Warn [PABLog]) . PP.vsep $ [ "Not all required signatures have signing key files. Please sign and submit the tx manually:" , "Tx file:" <+> pretty (Files.txFilePath pabConf "raw" (Tx.txId tx)) , "Signatories (pkh):" <+> pretty (Text.unwords (map pkhToText requiredSigners)) @@ -477,12 +478,12 @@ handleCollateral cEnv = do case result of Right collteralUtxo -> setInMemCollateral @w collteralUtxo - >> Right <$> printBpiLog @w Debug "successfully set the collateral utxo in env." + >> Right <$> printBpiLog @w (Debug [CollateralLog]) "successfully set the collateral utxo in env." Left err -> pure $ Left $ "Failed to make collateral: " <> err where -- helperLog :: PP.Doc () -> ExceptT CollateralUtxo (Eff effs) () - helperLog msg = newEitherT $ Right <$> printBpiLog @w Debug msg + helperLog msg = newEitherT $ Right <$> printBpiLog @w (Debug [CollateralLog]) msg {- | Create collateral UTxO by submitting Tx. Then try to find created UTxO at own PKH address. @@ -493,7 +494,7 @@ makeCollateral :: ContractEnvironment w -> Eff effs (Either Text CollateralUtxo) makeCollateral cEnv = runEitherT $ do - lift $ printBpiLog @w Notice "Making collateral" + lift $ printBpiLog @w (Notice [CollateralLog]) "Making collateral" let pabConf = cEnv.cePABConfig unbalancedTx <- @@ -512,7 +513,7 @@ makeCollateral cEnv = runEitherT $ do WriteBalancedTxFailed e -> throwE . T.pack $ "Failed to create collateral output: " <> show e WriteBalancedTxSuccess cTx -> do status <- lift $ awaitTxStatusChange cEnv (getCardanoTxId cTx) - lift $ printBpiLog @w Notice $ "Collateral Tx Status: " <> pretty status + lift $ printBpiLog @w (Notice [CollateralLog]) $ "Collateral Tx Status: " <> pretty status newEitherT $ findCollateralAtOwnPKH cEnv -- | Finds a collateral present at user's address diff --git a/src/BotPlutusInterface/Effects.hs b/src/BotPlutusInterface/Effects.hs index 32e33156..49bc1781 100644 --- a/src/BotPlutusInterface/Effects.hs +++ b/src/BotPlutusInterface/Effects.hs @@ -44,6 +44,7 @@ import BotPlutusInterface.Types ( ContractState (ContractState), LogContext (BpiLog, ContractLog), LogLevel (..), + LogType (..), LogsList (LogsList), TxBudget, TxFile, @@ -64,6 +65,7 @@ import Data.Aeson qualified as JSON import Data.Bifunctor (second) import Data.ByteString qualified as ByteString import Data.Kind (Type) +import Data.List (intersect) import Data.Maybe (catMaybes) import Data.String (IsString, fromString) import Data.Text (Text) @@ -191,12 +193,18 @@ handlePABEffect contractEnv = printLog' :: LogLevel -> LogContext -> LogLevel -> PP.Doc () -> IO () printLog' logLevelSetting msgCtx msgLogLvl msg = - when (logLevelSetting >= msgLogLvl) $ putStrLn target + when + ( logLevelSetting {ltLogTypes = mempty} >= msgLogLvl {ltLogTypes = mempty} + && not (null intersectLogTypes) + ) + $ putStrLn target where target = Render.renderString . layoutPretty defaultLayoutOptions $ prettyLog msgCtx msgLogLvl msg + intersectLogTypes = ltLogTypes logLevelSetting `intersect` (ltLogTypes msgLogLvl <> [AnyLog]) + prettyLog :: LogContext -> LogLevel -> PP.Doc () -> PP.Doc () prettyLog msgCtx msgLogLvl msg = pretty msgCtx <+> pretty msgLogLvl <+> msg @@ -217,14 +225,14 @@ handleContractLogInternal = reinterpret $ \case 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 + toNativeLogLevel Freer.Debug = Debug [AnyLog] + toNativeLogLevel Freer.Info = Info [AnyLog] + toNativeLogLevel Freer.Notice = Notice [AnyLog] + toNativeLogLevel Freer.Warning = Warn [AnyLog] + toNativeLogLevel Freer.Error = Error [AnyLog] + toNativeLogLevel Freer.Critical = Error [AnyLog] + toNativeLogLevel Freer.Alert = Error [AnyLog] + toNativeLogLevel Freer.Emergency = Error [AnyLog] callLocalCommand :: forall (a :: Type). ShellArgs a -> IO (Either Text a) callLocalCommand ShellArgs {cmdName, cmdArgs, cmdOutParser} = diff --git a/src/BotPlutusInterface/Types.hs b/src/BotPlutusInterface/Types.hs index 48950826..b69e3114 100644 --- a/src/BotPlutusInterface/Types.hs +++ b/src/BotPlutusInterface/Types.hs @@ -6,8 +6,9 @@ module BotPlutusInterface.Types ( PABConfig (..), CLILocation (..), AppState (AppState), - LogLevel (..), LogContext (..), + LogLevel (..), + LogType (..), ContractEnvironment (..), Tip (Tip, epoch, hash, slot, block, era, syncProgress), ContractState (..), @@ -245,16 +246,36 @@ data ContractState w = ContractState data CLILocation = Local | Remote Text deriving stock (Show, Eq) -data LogLevel = Error | Warn | Notice | Info | Debug - deriving stock (Bounded, Enum, Eq, Ord, Show) +data LogType + = CoinSelectionLog + | TxBalancingLog + | CollateralLog + | PABLog + | AnyLog + deriving stock (Eq, Ord, Show) + +instance Pretty LogType where + pretty CoinSelectionLog = "CoinSelection" + pretty TxBalancingLog = "TxBalancing" + pretty CollateralLog = "Collateral" + pretty PABLog = "PABLog" + pretty AnyLog = "Any" + +data LogLevel + = Error {ltLogTypes :: [LogType]} + | Warn {ltLogTypes :: [LogType]} + | Notice {ltLogTypes :: [LogType]} + | Info {ltLogTypes :: [LogType]} + | Debug {ltLogTypes :: [LogType]} + deriving stock (Eq, Ord, Show) instance Pretty LogLevel where pretty = \case - Debug -> "[DEBUG]" - Info -> "[INFO]" - Notice -> "[NOTICE]" - Warn -> "[WARNING]" - Error -> "[ERROR]" + Debug a -> "[DEBUG " <> pretty a <> "]" + Info a -> "[INFO " <> pretty a <> "]" + Notice a -> "[NOTICE " <> pretty a <> "]" + Warn a -> "[WARNING " <> pretty a <> "]" + Error a -> "[ERROR " <> pretty a <> "]" data LogContext = BpiLog | ContractLog deriving stock (Bounded, Enum, Eq, Ord, Show) @@ -278,7 +299,7 @@ instance Default PABConfig where , pcMetadataDir = "/metadata" , pcDryRun = True , pcProtocolParamsFile = "./protocol.json" - , pcLogLevel = Info + , pcLogLevel = Info [AnyLog] , pcOwnPubKeyHash = "" , pcOwnStakePubKeyHash = Nothing , pcPort = 9080 diff --git a/test/Spec/BotPlutusInterface/Config.hs b/test/Spec/BotPlutusInterface/Config.hs index 9176110f..d188b010 100644 --- a/test/Spec/BotPlutusInterface/Config.hs +++ b/test/Spec/BotPlutusInterface/Config.hs @@ -3,7 +3,13 @@ module Spec.BotPlutusInterface.Config (tests) where import BotPlutusInterface.Config (loadPABConfig, savePABConfig) -import BotPlutusInterface.Types (CLILocation (..), LogLevel (..), PABConfig (..), TxStatusPolling (TxStatusPolling)) +import BotPlutusInterface.Types ( + CLILocation (..), + LogLevel (..), + LogType (AnyLog), + PABConfig (..), + TxStatusPolling (TxStatusPolling), + ) import Cardano.Api ( AnyPlutusScriptVersion (..), CostModel (..), @@ -107,7 +113,7 @@ pabConfigExample = , pcMetadataDir = "path" , pcDryRun = False , pcProtocolParamsFile = "./protocol.json3" - , pcLogLevel = Debug + , pcLogLevel = Debug [AnyLog] , pcOwnPubKeyHash = "0f45aaf1b2959db6e5ff94dbb1f823bf257680c3c723ac2d49f97546" , pcOwnStakePubKeyHash = Just $ StakePubKeyHash "0f45aaf1b2959db6e5ff94dbb1f823bf257680c3c723ac2d49f97547" , pcPort = 1021