Skip to content

Commit 14518e0

Browse files
IAmPara0xIAmPara0x
committed
improve logging
1 parent 71d1bfd commit 14518e0

File tree

9 files changed

+63
-49
lines changed

9 files changed

+63
-49
lines changed

‎examples/debug/src/SomeDebugContract.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -4,6 +4,8 @@ module SomeDebugContract where
44

55
import Data.Map (size)
66
import Data.Map qualified as M
7+
import Data.Void (Void)
8+
import Data.Aeson.Extras (encodeByteString)
79
import Data.Text (Text)
810
import Debug.Trace (traceM)
911
import Ledger (Address (Address), PaymentPubKeyHash (PaymentPubKeyHash), getCardanoTxId)

‎examples/debug/src/TestRun.hs‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -7,7 +7,8 @@ import BotPlutusInterface.Types (
77
ContractEnvironment (..),
88
ContractState (ContractState),
99
ContractStats (ContractStats),
10-
LogLevel (Notice),
10+
LogLevel (Debug),
11+
LogType(..),
1112
LogsList (LogsList),
1213
PABConfig (..),
1314
TxStatusPolling (TxStatusPolling),
@@ -136,7 +137,7 @@ mkPabConf _ pparams pparamsFile bpiDir ownPkh =
136137
, pcSigningKeyFileDir = Text.pack $ bpiDir </> "signing-keys"
137138
, pcTxFileDir = Text.pack $ bpiDir </> "txs"
138139
, pcDryRun = False
139-
, pcLogLevel = Debug CoinSelectionLog
140+
, pcLogLevel = Debug [CoinSelectionLog, PABLog]
140141
, pcProtocolParamsFile = pparamsFile
141142
, pcEnableTxEndpoint = False
142143
, pcCollectStats = False

‎src/BotPlutusInterface/Balance.hs‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -125,7 +125,7 @@ balanceTxIO' balanceCfg pabConf ownPkh unbalancedTx =
125125
requiredSigs :: [PubKeyHash]
126126
requiredSigs = map Ledger.unPaymentPubKeyHash $ Map.keys (unBalancedTxRequiredSignatories unbalancedTx)
127127

128-
lift $ printBpiLog @w (Debug TxBalancingLog) $ viaShow utxoIndex
128+
lift $ printBpiLog @w (Debug [TxBalancingLog]) $ viaShow utxoIndex
129129

130130
-- We need this folder on the CLI machine, which may not be the local machine
131131
lift $ createDirectoryIfMissingCLI @w False (Text.unpack "pcTxFileDir")
@@ -166,7 +166,7 @@ balanceTxIO' balanceCfg pabConf ownPkh unbalancedTx =
166166
let finalAdaChange = getAdaChange utxoIndex balancedTxWithChange
167167
fullyBalancedTx = addAdaChange balanceCfg changeAddr finalAdaChange balancedTxWithChange
168168
txInfoLog =
169-
printBpiLog @w (Debug TxBalancingLog) $
169+
printBpiLog @w (Debug [TxBalancingLog]) $
170170
"UnbalancedTx TxInputs: "
171171
<+> pretty (length $ txInputs preBalancedTx)
172172
<+> "UnbalancedTx TxOutputs: "
@@ -198,7 +198,7 @@ balanceTxIO' balanceCfg pabConf ownPkh unbalancedTx =
198198

199199
let minUtxos = prevMinUtxos ++ nextMinUtxos
200200

201-
lift $ printBpiLog @w (Debug TxBalancingLog) $ "Min utxos:" <+> pretty minUtxos
201+
lift $ printBpiLog @w (Debug [TxBalancingLog]) $ "Min utxos:" <+> pretty minUtxos
202202

203203
-- Calculate fees by pre-balancing the tx, building it, and running the CLI on result
204204
txWithoutFees <-
@@ -210,7 +210,7 @@ balanceTxIO' balanceCfg pabConf ownPkh unbalancedTx =
210210

211211
let fees = nonBudgettedFees + getBudgetPrice (getExecutionUnitPrices pabConf) exBudget
212212

213-
lift $ printBpiLog @w (Debug TxBalancingLog) $ "Fees:" <+> pretty fees
213+
lift $ printBpiLog @w (Debug [TxBalancingLog]) $ "Fees:" <+> pretty fees
214214

215215
-- Rebalance the initial tx with the above fees
216216
balancedTx <- newEitherT $ balanceTxStep @w balanceCfg minUtxos utxoIndex changeAddr $ tx `withFee` fees

‎src/BotPlutusInterface/CoinSelection.hs‎

Lines changed: 8 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -65,7 +65,7 @@ selectTxIns originalTxIns utxosIndex outValue =
6565
(\k v -> k `notElem` txInRefs && isRight (txOutToTxIn (k, v)))
6666
utxosIndex
6767

68-
lift $ printBpiLog @w (Debug CoinSelectionLog) $ "Remaining UTxOs: " <+> pretty remainingUtxos
68+
lift $ printBpiLog @w (Debug [CoinSelectionLog]) $ "Remaining UTxOs: " <+> pretty remainingUtxos
6969

7070
txInsVec <-
7171
hoistEither $
@@ -79,14 +79,14 @@ selectTxIns originalTxIns utxosIndex outValue =
7979

8080
selectedUtxosIdxs <- newEitherT $ selectTxIns' @w GreedyPruning (isSufficient outVec) outVec txInsVec remainingUtxosVec
8181

82-
lift $ printBpiLog @w (Debug CoinSelectionLog) $ "" <+> "Selected UTxOs Index: " <+> pretty selectedUtxosIdxs
82+
lift $ printBpiLog @w (Debug [CoinSelectionLog]) $ "" <+> "Selected UTxOs Index: " <+> pretty selectedUtxosIdxs
8383

8484
let selectedUtxos :: [(TxOutRef, TxOut)]
8585
selectedUtxos = mapMaybe (\idx -> remainingUtxos ^? ix idx) selectedUtxosIdxs
8686

8787
selectedTxIns <- hoistEither $ mapM txOutToTxIn selectedUtxos
8888

89-
lift $ printBpiLog @w (Debug CoinSelectionLog) $ "Selected TxIns: " <+> pretty selectedTxIns
89+
lift $ printBpiLog @w (Debug [CoinSelectionLog]) $ "Selected TxIns: " <+> pretty selectedTxIns
9090

9191
return $ originalTxIns <> Set.fromList selectedTxIns
9292
where
@@ -117,10 +117,10 @@ greedySearch ::
117117
Eff effs (Either Text [Int])
118118
greedySearch stopSearch outVec txInsVec utxosVec
119119
| null utxosVec =
120-
printBpiLog @w (Debug CoinSelectionLog) "The list of remanining UTxO vectors in null."
120+
printBpiLog @w (Debug [CoinSelectionLog]) "Greedy: The list of remanining UTxO vectors in null."
121121
>> return (Right mempty)
122122
| stopSearch txInsVec =
123-
printBpiLog @w (Debug CoinSelectionLog) "Stopping search early."
123+
printBpiLog @w (Debug [CoinSelectionLog]) "Greedy: Stopping search early."
124124
>> return (Right mempty)
125125
| otherwise =
126126
runEitherT $ do
@@ -150,7 +150,7 @@ greedySearch stopSearch outVec txInsVec utxosVec
150150
newTxInsVec' <- hoistEither $ addVec newTxInsVec selectedUtxoVec
151151

152152
lift $
153-
printBpiLog @w (Debug CoinSelectionLog) $
153+
printBpiLog @w (Debug [CoinSelectionLog]) $
154154
"Loop Info: Stop search -> " <+> pretty (stopSearch newTxInsVec')
155155
<+> "Selected UTxo Idx : "
156156
<+> pretty idx
@@ -167,10 +167,10 @@ greedyPruning ::
167167
Eff effs (Either Text [Int])
168168
greedyPruning stopSearch outVec txInsVec utxosVec
169169
| null utxosVec =
170-
printBpiLog @w (Debug CoinSelectionLog) "The list of remanining UTxO vectors in null."
170+
printBpiLog @w (Debug [CoinSelectionLog]) "Greedy Pruning: The list of remanining UTxO vectors in null."
171171
>> return (Right mempty)
172172
| stopSearch txInsVec =
173-
printBpiLog @w (Debug CoinSelectionLog) "Stopping search early."
173+
printBpiLog @w (Debug [CoinSelectionLog]) "Greedy Pruning: Stopping search early."
174174
>> return (Right mempty)
175175
| otherwise =
176176
runEitherT $ do

‎src/BotPlutusInterface/Config.hs‎

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -76,11 +76,11 @@ instance ToValue LogLevel where
7676

7777
logLevelSpec :: ValueSpec LogLevel
7878
logLevelSpec =
79-
Error <$ atomSpec "error"
80-
<!> Warn <$ atomSpec "warn"
81-
<!> Notice <$ atomSpec "notice"
82-
<!> Info <$ atomSpec "info"
83-
<!> Debug AnyLog <$ atomSpec "debug"
79+
Error [AnyLog] <$ atomSpec "error"
80+
<!> Warn [AnyLog] <$ atomSpec "warn"
81+
<!> Notice [AnyLog] <$ atomSpec "notice"
82+
<!> Info [AnyLog] <$ atomSpec "info"
83+
<!> Debug [AnyLog] <$ atomSpec "debug"
8484

8585
instance ToValue TxStatusPolling where
8686
toValue (TxStatusPolling interval timeout) =

‎src/BotPlutusInterface/Contract.hs‎

Lines changed: 13 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -175,7 +175,7 @@ handlePABReq ::
175175
PABReq ->
176176
Eff effs PABResp
177177
handlePABReq contractEnv req = do
178-
printBpiLog @w (Debug PABLog) $ pretty req
178+
printBpiLog @w (Debug [PABLog]) $ pretty req
179179
resp <- case req of
180180
----------------------
181181
-- Handled requests --
@@ -209,7 +209,7 @@ handlePABReq contractEnv req = do
209209
-- YieldUnbalancedTxReq UnbalancedTx
210210
unsupported -> error ("Unsupported PAB effect: " ++ show unsupported)
211211

212-
printBpiLog @w (Debug PABLog) $ pretty resp
212+
printBpiLog @w (Debug [PABLog]) $ pretty resp
213213
pure resp
214214

215215
{- | Await till transaction status change to something from `Unknown`.
@@ -228,7 +228,7 @@ awaitTxStatusChange ::
228228
Eff effs TxStatus
229229
awaitTxStatusChange contractEnv txId = do
230230
checkStartedBlock <- currentBlock contractEnv
231-
printBpiLog @w (Debug PABLog) $ pretty $ "Awaiting status change for " ++ show txId
231+
printBpiLog @w (Debug [PABLog]) $ pretty $ "Awaiting status change for " ++ show txId
232232

233233
let txStatusPolling = contractEnv.cePABConfig.pcTxStatusPolling
234234
pollInterval = fromIntegral $ txStatusPolling.spInterval
@@ -240,7 +240,7 @@ awaitTxStatusChange contractEnv txId = do
240240
txStatus <- getStatus
241241
case (txStatus, currBlock > cutOffBlock) of
242242
(status, True) -> do
243-
helperLog (Debug PABLog) . mconcat . fmap mconcat $
243+
helperLog (Debug [PABLog]) . mconcat . fmap mconcat $
244244
[ ["Timeout for waiting `TxId ", show txId, "` status change reached"]
245245
, [" - waited ", show pollTimeout, " blocks."]
246246
, [" Current status: ", show status]
@@ -255,17 +255,17 @@ awaitTxStatusChange contractEnv txId = do
255255
mTx <- queryChainIndexForTxState
256256
case mTx of
257257
Nothing -> do
258-
helperLog (Debug PABLog) $ "TxId " ++ show txId ++ " not found in index"
258+
helperLog (Debug [PABLog]) $ "TxId " ++ show txId ++ " not found in index"
259259
pure Unknown
260260
Just txState -> do
261-
helperLog (Debug PABLog) $ "TxId " ++ show txId ++ " found in index, checking status"
261+
helperLog (Debug [PABLog]) $ "TxId " ++ show txId ++ " found in index, checking status"
262262
blk <- fromInteger <$> currentBlock contractEnv
263263
case transactionStatus blk txState txId of
264264
Left e -> do
265-
helperLog (Debug PABLog) $ "Status check for TxId " ++ show txId ++ " failed with " ++ show e
265+
helperLog (Debug [PABLog]) $ "Status check for TxId " ++ show txId ++ " failed with " ++ show e
266266
pure Unknown
267267
Right st -> do
268-
helperLog (Debug PABLog) $ "Status for TxId " ++ show txId ++ " is " ++ show st
268+
helperLog (Debug [PABLog]) $ "Status for TxId " ++ show txId ++ " is " ++ show st
269269
pure st
270270

271271
queryChainIndexForTxState :: Eff effs (Maybe TxIdState)
@@ -346,7 +346,7 @@ writeBalancedTx contractEnv (Right tx) = do
346346
if signable
347347
then newEitherT $ CardanoCLI.signTx @w pabConf tx requiredSigners
348348
else
349-
lift . printBpiLog @w Warn . PP.vsep $
349+
lift . printBpiLog @w (Warn [PABLog]) . PP.vsep $
350350
[ "Not all required signatures have signing key files. Please sign and submit the tx manually:"
351351
, "Tx file:" <+> pretty (Files.txFilePath pabConf "raw" (Tx.txId tx))
352352
, "Signatories (pkh):" <+> pretty (Text.unwords (map pkhToText requiredSigners))
@@ -485,12 +485,12 @@ handleCollateral cEnv = do
485485
case result of
486486
Right collteralUtxo ->
487487
setInMemCollateral @w collteralUtxo
488-
>> Right <$> printBpiLog @w (Debug PABLog) "successfully set the collateral utxo in env."
488+
>> Right <$> printBpiLog @w (Debug [PABLog]) "successfully set the collateral utxo in env."
489489
Left err -> pure $ Left $ "Failed to make collateral: " <> err
490490
where
491491
--
492492
helperLog :: PP.Doc () -> ExceptT CollateralUtxo (Eff effs) ()
493-
helperLog msg = newEitherT $ Right <$> printBpiLog @w (Debug CollateralLog) msg
493+
helperLog msg = newEitherT $ Right <$> printBpiLog @w (Debug [CollateralLog]) msg
494494

495495
{- | Create collateral UTxO by submitting Tx.
496496
Then try to find created UTxO at own PKH address.
@@ -501,7 +501,7 @@ makeCollateral ::
501501
ContractEnvironment w ->
502502
Eff effs (Either Text CollateralUtxo)
503503
makeCollateral cEnv = runEitherT $ do
504-
lift $ printBpiLog @w Notice "Making collateral"
504+
lift $ printBpiLog @w (Notice [CollateralLog]) "Making collateral"
505505

506506
let pabConf = cEnv.cePABConfig
507507
unbalancedTx <-
@@ -520,7 +520,7 @@ makeCollateral cEnv = runEitherT $ do
520520
WriteBalancedTxFailed e -> throwE . T.pack $ "Failed to create collateral output: " <> show e
521521
WriteBalancedTxSuccess cTx -> do
522522
status <- lift $ awaitTxStatusChange cEnv (getCardanoTxId cTx)
523-
lift $ printBpiLog @w Notice $ "Collateral Tx Status: " <> pretty status
523+
lift $ printBpiLog @w (Notice [CollateralLog]) $ "Collateral Tx Status: " <> pretty status
524524
newEitherT $ findCollateralAtOwnPKH cEnv
525525

526526
-- | Finds a collateral present at user's address

‎src/BotPlutusInterface/Effects.hs‎

Lines changed: 16 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -64,6 +64,7 @@ import Data.Aeson (ToJSON)
6464
import Data.Aeson qualified as JSON
6565
import Data.Bifunctor (second)
6666
import Data.ByteString qualified as ByteString
67+
import Data.List (intersect)
6768
import Data.Kind (Type)
6869
import Data.Maybe (catMaybes)
6970
import Data.String (IsString, fromString)
@@ -192,12 +193,18 @@ handlePABEffect contractEnv =
192193

193194
printLog' :: LogLevel -> LogContext -> LogLevel -> PP.Doc () -> IO ()
194195
printLog' logLevelSetting msgCtx msgLogLvl msg =
195-
when (logLevelSetting >= msgLogLvl) $ putStrLn target
196+
when
197+
(logLevelSetting {ltLogTypes = mempty} >= msgLogLvl {ltLogTypes = mempty}
198+
&& not (null intersectLogTypes))
199+
$ putStrLn target
196200
where
197201
target =
198202
Render.renderString . layoutPretty defaultLayoutOptions $
199203
prettyLog msgCtx msgLogLvl msg
200204

205+
intersectLogTypes = ltLogTypes logLevelSetting `intersect` (ltLogTypes msgLogLvl <> [AnyLog])
206+
207+
201208
prettyLog :: LogContext -> LogLevel -> PP.Doc () -> PP.Doc ()
202209
prettyLog msgCtx msgLogLvl msg = pretty msgCtx <+> pretty msgLogLvl <+> msg
203210

@@ -218,14 +225,14 @@ handleContractLogInternal = reinterpret $ \case
218225
msgPretty = pretty msgContent
219226
in printLog @w ContractLog msgLogLevel msgPretty
220227
where
221-
toNativeLogLevel Freer.Debug = Debug AnyLog
222-
toNativeLogLevel Freer.Info = Info
223-
toNativeLogLevel Freer.Notice = Notice
224-
toNativeLogLevel Freer.Warning = Warn
225-
toNativeLogLevel Freer.Error = Error
226-
toNativeLogLevel Freer.Critical = Error
227-
toNativeLogLevel Freer.Alert = Error
228-
toNativeLogLevel Freer.Emergency = Error
228+
toNativeLogLevel Freer.Debug = Debug [AnyLog]
229+
toNativeLogLevel Freer.Info = Info [AnyLog]
230+
toNativeLogLevel Freer.Notice = Notice [AnyLog]
231+
toNativeLogLevel Freer.Warning = Warn [AnyLog]
232+
toNativeLogLevel Freer.Error = Error [AnyLog]
233+
toNativeLogLevel Freer.Critical = Error [AnyLog]
234+
toNativeLogLevel Freer.Alert = Error [AnyLog]
235+
toNativeLogLevel Freer.Emergency = Error [AnyLog]
229236

230237
callLocalCommand :: forall (a :: Type). ShellArgs a -> IO (Either Text a)
231238
callLocalCommand ShellArgs {cmdName, cmdArgs, cmdOutParser} =

‎src/BotPlutusInterface/Types.hs‎

Lines changed: 11 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -258,19 +258,23 @@ instance Pretty LogType where
258258
pretty CoinSelectionLog = "CoinSelection"
259259
pretty TxBalancingLog = "TxBalancing"
260260
pretty CollateralLog = "Collateral"
261-
pretty PABLog = "Contract"
261+
pretty PABLog = "PABLog"
262262
pretty AnyLog = "Any"
263263

264-
data LogLevel = Error | Warn | Notice | Info | Debug LogType
264+
data LogLevel = Error { ltLogTypes :: [LogType] }
265+
| Warn { ltLogTypes :: [LogType] }
266+
| Notice { ltLogTypes :: [LogType] }
267+
| Info { ltLogTypes :: [LogType] }
268+
| Debug { ltLogTypes :: [LogType] }
265269
deriving stock (Eq, Ord, Show)
266270

267271
instance Pretty LogLevel where
268272
pretty = \case
269273
Debug a -> "[DEBUG " <> pretty a <> "]"
270-
Info -> "[INFO]"
271-
Notice -> "[NOTICE]"
272-
Warn -> "[WARNING]"
273-
Error -> "[ERROR]"
274+
Info a -> "[INFO " <> pretty a <> "]"
275+
Notice a -> "[NOTICE " <> pretty a <> "]"
276+
Warn a -> "[WARNING " <> pretty a <> "]"
277+
Error a -> "[ERROR " <> pretty a <> "]"
274278

275279
data LogContext = BpiLog | ContractLog
276280
deriving stock (Bounded, Enum, Eq, Ord, Show)
@@ -294,7 +298,7 @@ instance Default PABConfig where
294298
, pcMetadataDir = "/metadata"
295299
, pcDryRun = True
296300
, pcProtocolParamsFile = "./protocol.json"
297-
, pcLogLevel = Info
301+
, pcLogLevel = Info [AnyLog]
298302
, pcOwnPubKeyHash = ""
299303
, pcOwnStakePubKeyHash = Nothing
300304
, pcPort = 9080

‎test/Spec/BotPlutusInterface/Config.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -113,7 +113,7 @@ pabConfigExample =
113113
, pcMetadataDir = "path"
114114
, pcDryRun = False
115115
, pcProtocolParamsFile = "./protocol.json3"
116-
, pcLogLevel = Debug AnyLog
116+
, pcLogLevel = Debug [AnyLog]
117117
, pcOwnPubKeyHash = "0f45aaf1b2959db6e5ff94dbb1f823bf257680c3c723ac2d49f97546"
118118
, pcOwnStakePubKeyHash = Just $ StakePubKeyHash "0f45aaf1b2959db6e5ff94dbb1f823bf257680c3c723ac2d49f97547"
119119
, pcPort = 1021

0 commit comments

Comments
 (0)