Skip to content

Commit 3bd2209

Browse files
IAmPara0xIAmPara0x
committed
improve logging
1 parent dcbcbf1 commit 3bd2209

File tree

8 files changed

+68
-49
lines changed

8 files changed

+68
-49
lines changed

‎examples/debug/src/TestRun.hs‎

Lines changed: 2 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -7,14 +7,12 @@ import Cardano.Api.Shelley (ProtocolParameters)
77
import Control.Concurrent.STM (newTVarIO, readTVarIO)
88
import Control.Monad (void)
99
import Data.Aeson (decodeFileStrict)
10-
import Data.String (fromString)
1110
import Data.Text (Text)
1211

1312
import Data.Text qualified as Text
1413
import Data.UUID.V4 qualified as UUID
1514
import GHC.IO.Encoding
1615
import Ledger (PubKeyHash)
17-
import Ledger.Value qualified as Value
1816
import Plutus.PAB.Core.ContractInstance.STM (Activity (Active))
1917
import Servant.Client (BaseUrl (BaseUrl), Scheme (Http))
2018
import SomeDebugContract qualified
@@ -26,6 +24,7 @@ import Tools
2624
import Wallet.Types (ContractInstanceId (ContractInstanceId))
2725
import Prelude
2826

27+
main :: IO ()
2928
main = testnetRun
3029

3130
testnetRun :: IO ()
@@ -127,7 +126,7 @@ mkPabConf _ pparams pparamsFile bpiDir ownPkh =
127126
, pcSigningKeyFileDir = Text.pack $ bpiDir </> "signing-keys"
128127
, pcTxFileDir = Text.pack $ bpiDir </> "txs"
129128
, pcDryRun = False
130-
, pcLogLevel = Debug
129+
, pcLogLevel = Debug CoinSelectionLog
131130
, pcProtocolParamsFile = pparamsFile
132131
, pcEnableTxEndpoint = False
133132
, pcCollectStats = False

‎src/BotPlutusInterface/Balance.hs‎

Lines changed: 12 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -19,7 +19,14 @@ import BotPlutusInterface.Effects (
1919
)
2020
import BotPlutusInterface.Files (DummyPrivKey, unDummyPrivateKey)
2121
import BotPlutusInterface.Files qualified as Files
22-
import BotPlutusInterface.Types (CollateralUtxo, LogLevel (Debug), PABConfig, collateralTxOutRef, collateralValue)
22+
import BotPlutusInterface.Types (
23+
CollateralUtxo,
24+
LogLevel (Debug),
25+
LogType (TxBalancingLog),
26+
PABConfig,
27+
collateralTxOutRef,
28+
collateralValue,
29+
)
2330
import Cardano.Api (ExecutionUnitPrices (ExecutionUnitPrices))
2431
import Cardano.Api.Shelley (ProtocolParameters (protocolParamPrices))
2532
import Control.Monad (foldM, void, zipWithM)
@@ -128,7 +135,7 @@ balanceTxIO' pabConf ownPkh unbalancedTx balanceTxType =
128135
let utxoIndex = fmap Tx.toTxOut utxos <> unBalancedTxUtxoIndex unbalancedTx
129136
requiredSigs = map Ledger.unPaymentPubKeyHash $ Map.keys (unBalancedTxRequiredSignatories unbalancedTx)
130137

131-
lift $ printBpiLog @w Debug $ viaShow utxoIndex
138+
lift $ printBpiLog @w (Debug TxBalancingLog) $ viaShow utxoIndex
132139

133140
-- We need this folder on the CLI machine, which may not be the local machine
134141
lift $ createDirectoryIfMissingCLI @w False (Text.unpack "pcTxFileDir")
@@ -176,7 +183,7 @@ balanceTxIO' pabConf ownPkh unbalancedTx balanceTxType =
176183
let finalAdaChange = getAdaChange utxoIndex balancedTxWithChange
177184
fullyBalancedTx = addAdaChange changeAddr finalAdaChange balancedTxWithChange collateralTxOut
178185
txInfoLog =
179-
printBpiLog @w Debug $
186+
printBpiLog @w (Debug TxBalancingLog) $
180187
"UnbalancedTx TxInputs: "
181188
<+> pretty (length $ txInputs preBalancedTx)
182189
<+> "UnbalancedTx TxOutputs: "
@@ -208,7 +215,7 @@ balanceTxIO' pabConf ownPkh unbalancedTx balanceTxType =
208215

209216
let minUtxos = prevMinUtxos ++ nextMinUtxos
210217

211-
lift $ printBpiLog @w Debug $ "Min utxos:" <+> pretty minUtxos
218+
lift $ printBpiLog @w (Debug TxBalancingLog) $ "Min utxos:" <+> pretty minUtxos
212219

213220
-- Calculate fees by pre-balancing the tx, building it, and running the CLI on result
214221
txWithoutFees <-
@@ -220,7 +227,7 @@ balanceTxIO' pabConf ownPkh unbalancedTx balanceTxType =
220227

221228
let fees = nonBudgettedFees + getBudgetPrice (getExecutionUnitPrices pabConf) exBudget
222229

223-
lift $ printBpiLog @w Debug $ "Fees:" <+> pretty fees
230+
lift $ printBpiLog @w (Debug TxBalancingLog) $ "Fees:" <+> pretty fees
224231

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

‎src/BotPlutusInterface/CoinSelection.hs‎

Lines changed: 8 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -2,7 +2,7 @@
22

33
module BotPlutusInterface.CoinSelection (valueToVec, valuesToVecs, selectTxIns) where
44

5-
import Control.Lens (Cons, cons, ix, uncons, (^?))
5+
import Control.Lens (ix, (^?))
66
import Control.Monad.Freer (Eff, Member)
77

88
import Control.Monad.Trans.Class (lift)
@@ -27,7 +27,7 @@ import Plutus.V1.Ledger.Api (
2727
)
2828

2929
import BotPlutusInterface.Effects (PABEffect, printBpiLog)
30-
import BotPlutusInterface.Types (LogLevel (Debug))
30+
import BotPlutusInterface.Types (LogLevel (Debug), LogType (CoinSelectionLog))
3131

3232
import Prettyprinter (pretty, (<+>))
3333
import Prelude
@@ -62,7 +62,7 @@ selectTxIns originalTxIns utxosIndex outValue =
6262
(\k v -> k `notElem` txInRefs && isRight (txOutToTxIn (k, v)))
6363
utxosIndex
6464

65-
lift $ printBpiLog @w Debug $ "Remaining UTxOs: " <+> pretty remainingUtxos <+> "\n\n"
65+
lift $ printBpiLog @w (Debug CoinSelectionLog) $ "Remaining UTxOs: " <+> pretty remainingUtxos
6666

6767
txInsVec <-
6868
hoistEither $
@@ -76,14 +76,14 @@ selectTxIns originalTxIns utxosIndex outValue =
7676

7777
selectedUtxosIdxs <- newEitherT $ selectTxIns' @w Greedy (isSufficient outVec) outVec txInsVec remainingUtxosVec
7878

79-
lift $ printBpiLog @w Debug $ "" <+> "Selected UTxOs Index: " <+> pretty selectedUtxosIdxs <+> "\n\n"
79+
lift $ printBpiLog @w (Debug CoinSelectionLog) $ "" <+> "Selected UTxOs Index: " <+> pretty selectedUtxosIdxs
8080

8181
let selectedUtxos :: [(TxOutRef, TxOut)]
8282
selectedUtxos = mapMaybe (\idx -> remainingUtxos ^? ix (fromInteger idx)) selectedUtxosIdxs
8383

8484
selectedTxIns <- hoistEither $ mapM txOutToTxIn selectedUtxos
8585

86-
lift $ printBpiLog @w Debug $ "Selected TxIns: " <+> pretty selectedTxIns <+> "\n\n"
86+
lift $ printBpiLog @w (Debug CoinSelectionLog) $ "Selected TxIns: " <+> pretty selectedTxIns
8787

8888
return $ originalTxIns <> Set.fromList selectedTxIns
8989
where
@@ -103,10 +103,10 @@ selectTxIns' ::
103103
Eff effs (Either Text [Integer])
104104
selectTxIns' Greedy stopSearch outVec txInsVec utxosVec
105105
| null utxosVec =
106-
printBpiLog @w Debug "The list of remanining UTxO vectors in null.\n\n"
106+
printBpiLog @w (Debug CoinSelectionLog) "The list of remanining UTxO vectors in null."
107107
>> return (Right mempty)
108108
| stopSearch txInsVec =
109-
printBpiLog @w Debug "Stopping search early.\n\n"
109+
printBpiLog @w (Debug CoinSelectionLog) "Stopping search early."
110110
>> return (Right mempty)
111111
| otherwise =
112112
runEitherT $ do
@@ -134,11 +134,10 @@ selectTxIns' Greedy stopSearch outVec txInsVec utxosVec
134134
newTxInsVec' <- hoistEither $ addVec newTxInsVec selectedUtxoVec
135135

136136
lift $
137-
printBpiLog @w Debug $
137+
printBpiLog @w (Debug CoinSelectionLog) $
138138
"Loop Info: Stop search -> " <+> pretty (stopSearch newTxInsVec')
139139
<+> "Selected UTxo Idx : "
140140
<+> pretty idx
141-
<+> "\n\n"
142141

143142
(idx :) <$> newEitherT (loop remSortedDist newTxInsVec')
144143

@@ -201,16 +200,3 @@ txOutToTxIn (txOutRef, txOut) =
201200
case addressCredential (txOutAddress txOut) of
202201
PubKeyCredential _ -> Right $ pubKeyTxIn txOutRef
203202
ScriptCredential _ -> Left "Cannot covert a script output to TxIn"
204-
205-
pop ::
206-
forall (v :: Type -> Type) a.
207-
(Cons (v a) (v a) a a) =>
208-
v a ->
209-
Integer ->
210-
Either Text (a, v a)
211-
pop va idx = do
212-
(a, va') <- maybeToRight "Error: Not able to uncons from empty structure." $ uncons va
213-
214-
if idx == 0
215-
then return (a, va')
216-
else pop va' (idx - 1) >>= (\(a', va'') -> return (a', cons a va''))

‎src/BotPlutusInterface/Config.hs‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -17,6 +17,7 @@ import BotPlutusInterface.Effects (
1717
import BotPlutusInterface.Types (
1818
CLILocation (..),
1919
LogLevel (..),
20+
LogType (AnyLog),
2021
PABConfig (..),
2122
TxStatusPolling (TxStatusPolling, spBlocksTimeOut, spInterval),
2223
)
@@ -79,7 +80,7 @@ logLevelSpec =
7980
<!> Warn <$ atomSpec "warn"
8081
<!> Notice <$ atomSpec "notice"
8182
<!> Info <$ atomSpec "info"
82-
<!> Debug <$ atomSpec "debug"
83+
<!> Debug AnyLog <$ atomSpec "debug"
8384

8485
instance ToValue TxStatusPolling where
8586
toValue (TxStatusPolling interval timeout) =

‎src/BotPlutusInterface/Contract.hs‎

Lines changed: 15 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -35,6 +35,7 @@ import BotPlutusInterface.Types (
3535
CollateralUtxo (CollateralUtxo),
3636
ContractEnvironment (..),
3737
LogLevel (Debug, Notice, Warn),
38+
LogType (PABLog, CollateralLog),
3839
Tip (block, slot),
3940
TxFile (Signed),
4041
collateralValue,
@@ -174,7 +175,7 @@ handlePABReq ::
174175
PABReq ->
175176
Eff effs PABResp
176177
handlePABReq contractEnv req = do
177-
printBpiLog @w Debug $ pretty req
178+
printBpiLog @w (Debug PABLog) $ pretty req
178179
resp <- case req of
179180
----------------------
180181
-- Handled requests --
@@ -208,7 +209,7 @@ handlePABReq contractEnv req = do
208209
-- YieldUnbalancedTxReq UnbalancedTx
209210
unsupported -> error ("Unsupported PAB effect: " ++ show unsupported)
210211

211-
printBpiLog @w Debug $ pretty resp
212+
printBpiLog @w (Debug PABLog) $ pretty resp
212213
pure resp
213214

214215
{- | Await till transaction status change to something from `Unknown`.
@@ -227,7 +228,7 @@ awaitTxStatusChange ::
227228
Eff effs TxStatus
228229
awaitTxStatusChange contractEnv txId = do
229230
checkStartedBlock <- currentBlock contractEnv
230-
printBpiLog @w Debug $ pretty $ "Awaiting status change for " ++ show txId
231+
printBpiLog @w (Debug PABLog) $ pretty $ "Awaiting status change for " ++ show txId
231232

232233
let txStatusPolling = contractEnv.cePABConfig.pcTxStatusPolling
233234
pollInterval = fromIntegral $ txStatusPolling.spInterval
@@ -239,7 +240,7 @@ awaitTxStatusChange contractEnv txId = do
239240
txStatus <- getStatus
240241
case (txStatus, currBlock > cutOffBlock) of
241242
(status, True) -> do
242-
logDebug . mconcat . fmap mconcat $
243+
helperLog (Debug PABLog) . mconcat . fmap mconcat $
243244
[ ["Timeout for waiting `TxId ", show txId, "` status change reached"]
244245
, [" - waited ", show pollTimeout, " blocks."]
245246
, [" Current status: ", show status]
@@ -254,17 +255,17 @@ awaitTxStatusChange contractEnv txId = do
254255
mTx <- queryChainIndexForTxState
255256
case mTx of
256257
Nothing -> do
257-
logDebug $ "TxId " ++ show txId ++ " not found in index"
258+
helperLog (Debug PABLog) $ "TxId " ++ show txId ++ " not found in index"
258259
pure Unknown
259260
Just txState -> do
260-
logDebug $ "TxId " ++ show txId ++ " found in index, checking status"
261+
helperLog (Debug PABLog) $ "TxId " ++ show txId ++ " found in index, checking status"
261262
blk <- fromInteger <$> currentBlock contractEnv
262263
case transactionStatus blk txState txId of
263264
Left e -> do
264-
logDebug $ "Status check for TxId " ++ show txId ++ " failed with " ++ show e
265+
helperLog (Debug PABLog) $ "Status check for TxId " ++ show txId ++ " failed with " ++ show e
265266
pure Unknown
266267
Right st -> do
267-
logDebug $ "Status for TxId " ++ show txId ++ " is " ++ show st
268+
helperLog (Debug PABLog) $ "Status for TxId " ++ show txId ++ " is " ++ show st
268269
pure st
269270

270271
queryChainIndexForTxState :: Eff effs (Maybe TxIdState)
@@ -276,7 +277,8 @@ awaitTxStatusChange contractEnv txId = do
276277
pure . Just $ fromTx blk tx
277278
Nothing -> pure Nothing
278279

279-
logDebug = printBpiLog @w Debug . pretty
280+
helperLog :: LogLevel -> String -> Eff effs ()
281+
helperLog (Debug a) = printBpiLog @w (Debug a) . pretty
280282

281283
-- | This will FULLY balance a transaction
282284
balanceTx ::
@@ -400,7 +402,8 @@ awaitSlot contractEnv s@(Slot n) = do
400402
_ -> awaitSlot contractEnv s
401403

402404
{- | Wait at least until the given time. Uses the awaitSlot under the hood, so the same constraints
403-
are applying here as well.
405+
are applying here as well. PubKeyCredential: 8cf10ef973d90f42c386cbdbceb1d731c9af1ec71b
406+
47329f8be130cf (no staking crede
404407
-}
405408
awaitTime ::
406409
forall (w :: Type) (effs :: [Type -> Type]).
@@ -474,12 +477,12 @@ handleCollateral cEnv = do
474477
case result of
475478
Right collteralUtxo ->
476479
setInMemCollateral @w collteralUtxo
477-
>> Right <$> printBpiLog @w Debug "successfully set the collateral utxo in env."
480+
>> Right <$> printBpiLog @w (Debug PABLog) "successfully set the collateral utxo in env."
478481
Left err -> pure $ Left $ "Failed to make collateral: " <> err
479482
where
480483
--
481484
helperLog :: PP.Doc () -> ExceptT CollateralUtxo (Eff effs) ()
482-
helperLog msg = newEitherT $ Right <$> printBpiLog @w Debug msg
485+
helperLog msg = newEitherT $ Right <$> printBpiLog @w (Debug CollateralLog) msg
483486

484487
{- | Create collateral UTxO by submitting Tx.
485488
Then try to find created UTxO at own PKH address.

‎src/BotPlutusInterface/Effects.hs‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -44,6 +44,7 @@ import BotPlutusInterface.Types (
4444
ContractState (ContractState),
4545
LogContext (BpiLog, ContractLog),
4646
LogLevel (..),
47+
LogType (AnyLog),
4748
LogsList (LogsList),
4849
TxBudget,
4950
TxFile,
@@ -217,7 +218,7 @@ handleContractLogInternal = reinterpret $ \case
217218
msgPretty = pretty msgContent
218219
in printLog @w ContractLog msgLogLevel msgPretty
219220
where
220-
toNativeLogLevel Freer.Debug = Debug
221+
toNativeLogLevel Freer.Debug = Debug AnyLog
221222
toNativeLogLevel Freer.Info = Info
222223
toNativeLogLevel Freer.Notice = Notice
223224
toNativeLogLevel Freer.Warning = Warn

‎src/BotPlutusInterface/Types.hs‎

Lines changed: 19 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -24,6 +24,7 @@ module BotPlutusInterface.Types (
2424
ContractStats (..),
2525
TxStatusPolling (..),
2626
LogsList (..),
27+
LogType (..),
2728
CollateralUtxo (..),
2829
CollateralVar (..),
2930
addBudget,
@@ -245,12 +246,27 @@ data ContractState w = ContractState
245246
data CLILocation = Local | Remote Text
246247
deriving stock (Show, Eq)
247248

248-
data LogLevel = Error | Warn | Notice | Info | Debug
249-
deriving stock (Bounded, Enum, Eq, Ord, Show)
249+
data LogType
250+
= CoinSelectionLog
251+
| TxBalancingLog
252+
| CollateralLog
253+
| PABLog
254+
| AnyLog
255+
deriving stock (Eq, Ord, Show)
256+
257+
instance Pretty LogType where
258+
pretty CoinSelectionLog = "CoinSelection"
259+
pretty TxBalancingLog = "TxBalancing"
260+
pretty CollateralLog = "Collateral"
261+
pretty PABLog = "Contract"
262+
pretty AnyLog = "Any"
263+
264+
data LogLevel = Error | Warn | Notice | Info | Debug LogType
265+
deriving stock (Eq, Ord, Show)
250266

251267
instance Pretty LogLevel where
252268
pretty = \case
253-
Debug -> "[DEBUG]"
269+
Debug a -> "[DEBUG " <> pretty a <> "]"
254270
Info -> "[INFO]"
255271
Notice -> "[NOTICE]"
256272
Warn -> "[WARNING]"

‎test/Spec/BotPlutusInterface/Config.hs‎

Lines changed: 8 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -3,7 +3,13 @@
33
module Spec.BotPlutusInterface.Config (tests) where
44

55
import BotPlutusInterface.Config (loadPABConfig, savePABConfig)
6-
import BotPlutusInterface.Types (CLILocation (..), LogLevel (..), PABConfig (..), TxStatusPolling (TxStatusPolling))
6+
import BotPlutusInterface.Types (
7+
CLILocation (..),
8+
LogLevel (..),
9+
LogType (AnyLog),
10+
PABConfig (..),
11+
TxStatusPolling (TxStatusPolling),
12+
)
713
import Cardano.Api (
814
AnyPlutusScriptVersion (..),
915
CostModel (..),
@@ -107,7 +113,7 @@ pabConfigExample =
107113
, pcMetadataDir = "path"
108114
, pcDryRun = False
109115
, pcProtocolParamsFile = "./protocol.json3"
110-
, pcLogLevel = Debug
116+
, pcLogLevel = Debug AnyLog
111117
, pcOwnPubKeyHash = "0f45aaf1b2959db6e5ff94dbb1f823bf257680c3c723ac2d49f97546"
112118
, pcOwnStakePubKeyHash = Just $ StakePubKeyHash "0f45aaf1b2959db6e5ff94dbb1f823bf257680c3c723ac2d49f97547"
113119
, pcPort = 1021

0 commit comments

Comments
 (0)