Skip to content

Commit e85fcf6

Browse files
samuelWilliams99samuelWilliams99
authored
Merge branch 'master' into collateral-ignore
2 parents 2590c3d + 6de6e56 commit e85fcf6

File tree

6 files changed

+133
-35
lines changed

6 files changed

+133
-35
lines changed

‎bot-plutus-interface.cabal‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -124,6 +124,7 @@ library
124124
, plutus-pab
125125
, plutus-tx
126126
, plutus-tx-plugin
127+
, prettyprinter
127128
, process
128129
, QuickCheck
129130
, row-types
@@ -140,6 +141,7 @@ library
140141
, transformers-except
141142
, unordered-containers
142143
, uuid
144+
, vector
143145
, wai
144146
, warp
145147
, websockets
@@ -193,6 +195,7 @@ test-suite bot-plutus-interface-test
193195
, plutus-pab
194196
, plutus-tx
195197
, plutus-tx-plugin
198+
, prettyprinter
196199
, QuickCheck
197200
, quickcheck-instances
198201
, row-types

‎src/BotPlutusInterface/Balance.hs‎

Lines changed: 5 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -8,7 +8,7 @@ module BotPlutusInterface.Balance (
88
) where
99

1010
import BotPlutusInterface.CardanoCLI qualified as CardanoCLI
11-
import BotPlutusInterface.Effects (PABEffect, createDirectoryIfMissingCLI, printLog)
11+
import BotPlutusInterface.Effects (PABEffect, createDirectoryIfMissingCLI, printBpiLog)
1212
import BotPlutusInterface.Files (DummyPrivKey, unDummyPrivateKey)
1313
import BotPlutusInterface.Files qualified as Files
1414
import BotPlutusInterface.Types (LogLevel (Debug), PABConfig)
@@ -61,6 +61,7 @@ import Plutus.V1.Ledger.Api (
6161
)
6262

6363
import BotPlutusInterface.BodyBuilder qualified as BodyBuilder
64+
import Prettyprinter (pretty, viaShow, (<+>))
6465
import Prelude
6566

6667
{- | Collect necessary tx inputs and collaterals, add minimum lovelace values and balance non ada
@@ -87,7 +88,7 @@ balanceTxIO pabConf ownPkh unbalancedTx =
8788
(unBalancedTxValidityTimeRange unbalancedTx)
8889
(unBalancedTxTx unbalancedTx)
8990

90-
lift $ printLog @w Debug $ show utxoIndex
91+
lift $ printBpiLog @w Debug $ viaShow utxoIndex
9192

9293
-- We need this folder on the CLI machine, which may not be the local machine
9394
lift $ createDirectoryIfMissingCLI @w False (Text.unpack pabConf.pcTxFileDir)
@@ -131,7 +132,7 @@ balanceTxIO pabConf ownPkh unbalancedTx =
131132

132133
let minUtxos = prevMinUtxos ++ nextMinUtxos
133134

134-
lift $ printLog @w Debug $ "Min utxos: " ++ show minUtxos
135+
lift $ printBpiLog @w Debug $ "Min utxos:" <+> pretty minUtxos
135136

136137
-- Calculate fees by pre-balancing the tx, building it, and running the CLI on result
137138
txWithoutFees <-
@@ -143,7 +144,7 @@ balanceTxIO pabConf ownPkh unbalancedTx =
143144

144145
let fees = nonBudgettedFees + getBudgetPrice (getExecutionUnitPrices pabConf) exBudget
145146

146-
lift $ printLog @w Debug $ "Fees: " ++ show fees
147+
lift $ printBpiLog @w Debug $ "Fees:" <+> pretty fees
147148

148149
-- Rebalance the initial tx with the above fees
149150
balancedTx <- hoistEither $ balanceTxStep minUtxos utxoIndex changeAddr $ tx `withFee` fees

‎src/BotPlutusInterface/Contract.hs‎

Lines changed: 48 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
11
{-# LANGUAGE AllowAmbiguousTypes #-}
22
{-# LANGUAGE RankNTypes #-}
3+
{-# OPTIONS_GHC -Wno-orphans #-}
34

45
module BotPlutusInterface.Contract (runContract, handleContract) where
56

@@ -12,9 +13,10 @@ import BotPlutusInterface.Effects (
1213
callCommand,
1314
createDirectoryIfMissing,
1415
estimateBudget,
16+
handleContractLog,
1517
handlePABEffect,
1618
logToContract,
17-
printLog,
19+
printBpiLog,
1820
queryChainIndex,
1921
readFileTextEnvelope,
2022
saveBudget,
@@ -34,19 +36,20 @@ import Control.Lens (preview, (^.))
3436
import Control.Monad (join, void, when)
3537
import Control.Monad.Freer (Eff, Member, interpret, reinterpret, runM, subsume, type (~>))
3638
import Control.Monad.Freer.Error (runError)
37-
import Control.Monad.Freer.Extras.Log (handleLogIgnore)
3839
import Control.Monad.Freer.Extras.Modify (raiseEnd)
3940
import Control.Monad.Freer.Writer (Writer (Tell))
4041
import Control.Monad.Trans.Class (lift)
4142
import Control.Monad.Trans.Either (EitherT, eitherT, firstEitherT, newEitherT)
42-
import Data.Aeson (ToJSON, Value)
43+
import Data.Aeson (ToJSON, Value (Array, Bool, Null, Number, Object, String))
4344
import Data.Aeson.Extras (encodeByteString)
4445
import Data.Either (fromRight)
46+
import Data.HashMap.Strict qualified as HM
4547
import Data.Kind (Type)
4648
import Data.Map qualified as Map
4749
import Data.Row (Row)
4850
import Data.Text (Text)
4951
import Data.Text qualified as Text
52+
import Data.Vector qualified as V
5053
import Ledger (POSIXTime)
5154
import Ledger qualified
5255
import Ledger.Address (PaymentPubKeyHash (PaymentPubKeyHash))
@@ -69,6 +72,8 @@ import Plutus.Contract.Effects (
6972
import Plutus.Contract.Resumable (Resumable (..))
7073
import Plutus.Contract.Types (Contract (..), ContractEffs)
7174
import PlutusTx.Builtins (fromBuiltin)
75+
import Prettyprinter (Pretty (pretty), (<+>))
76+
import Prettyprinter qualified as PP
7277
import Wallet.Emulator.Error (WalletAPIError (..))
7378
import Prelude
7479

@@ -92,10 +97,29 @@ handleContract contractEnv =
9297
. handleResumable contractEnv
9398
. handleCheckpointIgnore
9499
. handleWriter
95-
. handleLogIgnore @Value
100+
. handleContractLog @w
96101
. runError
97102
. raiseEnd
98103

104+
instance Pretty Value where
105+
pretty (String s) = pretty s
106+
pretty (Number n) = pretty $ show n
107+
pretty (Bool b) = pretty b
108+
pretty (Array arr) = PP.list $ pretty <$> V.toList arr
109+
pretty (Object obj) =
110+
PP.group
111+
. PP.encloseSep (PP.flatAlt "{ " "{") (PP.flatAlt " }" "}") ", "
112+
. map
113+
( \(k, v) ->
114+
PP.hang 2 $
115+
PP.sep
116+
[ pretty k <+> ": "
117+
, pretty v
118+
]
119+
)
120+
$ HM.toList obj
121+
pretty Null = "null"
122+
99123
handleWriter ::
100124
forall (w :: Type) (effs :: [Type -> Type]).
101125
(ToJSON w, Monoid w) =>
@@ -140,7 +164,7 @@ handlePABReq ::
140164
PABReq ->
141165
Eff effs PABResp
142166
handlePABReq contractEnv req = do
143-
printLog @w Debug $ show req
167+
printBpiLog @w Debug $ pretty req
144168
resp <- case req of
145169
----------------------
146170
-- Handled requests --
@@ -176,7 +200,7 @@ handlePABReq contractEnv req = do
176200
-- YieldUnbalancedTxReq UnbalancedTx
177201
unsupported -> error ("Unsupported PAB effect: " ++ show unsupported)
178202

179-
printLog @w Debug $ show resp
203+
printBpiLog @w Debug $ pretty resp
180204
pure resp
181205

182206
awaitTxStatusChange ::
@@ -193,7 +217,7 @@ awaitTxStatusChange contractEnv txId = do
193217
case mTx of
194218
Nothing -> pure Unknown
195219
Just txState -> do
196-
printLog @w Debug $ "Found transaction in node, waiting " ++ show chainConstant ++ " blocks for it to settle."
220+
printBpiLog @w Debug $ "Found transaction in node, waiting" <+> pretty chainConstant <+> " blocks for it to settle."
197221
awaitNBlocks @w contractEnv (chainConstant + 1)
198222
-- Check if the tx is still present in chain-index, in case of a rollback
199223
-- we might not find it anymore.
@@ -268,12 +292,15 @@ writeBalancedTx contractEnv (Right tx) = do
268292
if signable
269293
then newEitherT $ CardanoCLI.signTx @w pabConf tx requiredSigners
270294
else
271-
lift . printLog @w Warn . Text.unpack . Text.unlines $
295+
lift . printBpiLog @w Warn . PP.vsep $
272296
[ "Not all required signatures have signing key files. Please sign and submit the tx manually:"
273-
, "Tx file: " <> Files.txFilePath pabConf "raw" (Tx.txId tx)
274-
, "Signatories (pkh): " <> Text.unwords (map pkhToText requiredSigners)
297+
, "Tx file:" <+> pretty (Files.txFilePath pabConf "raw" (Tx.txId tx))
298+
, "Signatories (pkh):" <+> pretty (Text.unwords (map pkhToText requiredSigners))
275299
]
276300

301+
when (pabConf.pcCollectStats && signable) $
302+
collectBudgetStats (Tx.txId tx) pabConf
303+
277304
when (not pabConf.pcDryRun && signable) $ do
278305
newEitherT $ CardanoCLI.submitTx @w pabConf tx
279306

@@ -284,9 +311,6 @@ writeBalancedTx contractEnv (Right tx) = do
284311
mvFiles (Files.txFilePath pabConf "raw" (Tx.txId tx)) (Files.txFilePath pabConf "raw" cardanoTxId)
285312
when signable $ mvFiles signedSrcPath signedDstPath
286313

287-
when contractEnv.cePABConfig.pcCollectStats $
288-
collectBudgetStats cardanoTxId signedDstPath
289-
290314
pure cardanoTx
291315
where
292316
mvFiles :: Text -> Text -> EitherT Text (Eff effs) ()
@@ -299,10 +323,17 @@ writeBalancedTx contractEnv (Right tx) = do
299323
, cmdOutParser = const ()
300324
}
301325

302-
collectBudgetStats txId txPath = do
303-
let path = Text.unpack txPath
304-
b <- firstEitherT (Text.pack . show) $ newEitherT $ estimateBudget @w (Signed path)
305-
void $ newEitherT (Right <$> saveBudget @w txId b)
326+
collectBudgetStats txId pabConf = do
327+
let path = Text.unpack (Files.txFilePath pabConf "signed" (Tx.txId tx))
328+
txBudget <-
329+
firstEitherT toBudgetSaveError $
330+
newEitherT $ estimateBudget @w (Signed path)
331+
void $ newEitherT (Right <$> saveBudget @w txId txBudget)
332+
333+
toBudgetSaveError =
334+
Text.pack
335+
. ("Failed to save Tx budgets statistics: " ++)
336+
. show
306337

307338
pkhToText :: Ledger.PubKey -> Text
308339
pkhToText = encodeByteString . fromBuiltin . Ledger.getPubKeyHash . Ledger.pubKeyHash

‎src/BotPlutusInterface/Effects.hs‎

Lines changed: 51 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -14,6 +14,8 @@ module BotPlutusInterface.Effects (
1414
uploadDir,
1515
updateInstanceState,
1616
printLog,
17+
printBpiLog,
18+
handleContractLog,
1719
logToContract,
1820
readFileTextEnvelope,
1921
writeFileJSON,
@@ -31,6 +33,7 @@ import BotPlutusInterface.Types (
3133
CLILocation (..),
3234
ContractEnvironment,
3335
ContractState (ContractState),
36+
LogContext (BpiLog, ContractLog),
3437
LogLevel (..),
3538
TxBudget,
3639
TxFile,
@@ -40,8 +43,11 @@ import Cardano.Api (AsType, FileError (FileIOError), HasTextEnvelope, TextEnvelo
4043
import Cardano.Api qualified
4144
import Control.Concurrent qualified as Concurrent
4245
import Control.Concurrent.STM (atomically, modifyTVar, modifyTVar')
46+
import Control.Lens ((^.))
4347
import Control.Monad (void, when)
44-
import Control.Monad.Freer (Eff, LastMember, Member, interpretM, send, type (~>))
48+
import Control.Monad.Freer (Eff, LastMember, Member, interpretM, reinterpret, send, subsume, type (~>))
49+
import Control.Monad.Freer.Extras (LogMsg (LMessage))
50+
import Control.Monad.Freer.Extras qualified as Freer
4551
import Control.Monad.Trans.Except.Extra (handleIOExceptT, runExceptT)
4652
import Data.Aeson (ToJSON)
4753
import Data.Aeson qualified as JSON
@@ -56,6 +62,9 @@ import Ledger qualified
5662
import Plutus.Contract.Effects (ChainIndexQuery, ChainIndexResponse)
5763
import Plutus.PAB.Core.ContractInstance.STM (Activity)
5864
import PlutusTx.Builtins.Internal (BuiltinByteString (BuiltinByteString))
65+
import Prettyprinter (Pretty (pretty), defaultLayoutOptions, layoutPretty, (<+>))
66+
import Prettyprinter qualified as PP
67+
import Prettyprinter.Render.String qualified as Render
5968
import System.Directory qualified as Directory
6069
import System.Exit (ExitCode (ExitFailure, ExitSuccess))
6170
import System.Process (readProcess, readProcessWithExitCode)
@@ -75,7 +84,7 @@ data PABEffect (w :: Type) (r :: Type) where
7584
CreateDirectoryIfMissing :: Bool -> FilePath -> PABEffect w ()
7685
-- Same as above but creates folder on the CLI machine, be that local or remote.
7786
CreateDirectoryIfMissingCLI :: Bool -> FilePath -> PABEffect w ()
78-
PrintLog :: LogLevel -> String -> PABEffect w ()
87+
PrintLog :: LogContext -> LogLevel -> PP.Doc () -> PABEffect w ()
7988
UpdateInstanceState :: Activity -> PABEffect w ()
8089
LogToContract :: (ToJSON w, Monoid w) => w -> PABEffect w ()
8190
ThreadDelay :: Int -> PABEffect w ()
@@ -117,7 +126,7 @@ handlePABEffect contractEnv =
117126
case contractEnv.cePABConfig.pcCliLocation of
118127
Local -> Directory.createDirectoryIfMissing createParents filePath
119128
Remote ipAddr -> createDirectoryIfMissingRemote ipAddr createParents filePath
120-
PrintLog logLevel txt -> printLog' contractEnv.cePABConfig.pcLogLevel logLevel txt
129+
PrintLog logCtx logLevel txt -> printLog' contractEnv.cePABConfig.pcLogLevel logCtx logLevel txt
121130
UpdateInstanceState s -> do
122131
atomically $
123132
modifyTVar contractEnv.ceContractState $
@@ -148,9 +157,34 @@ handlePABEffect contractEnv =
148157
SaveBudget txId exBudget -> saveBudgetImpl contractEnv txId exBudget
149158
)
150159

151-
printLog' :: LogLevel -> LogLevel -> String -> IO ()
152-
printLog' logLevelSetting msgLogLvl msg =
153-
when (logLevelSetting >= msgLogLvl) $ putStrLn msg
160+
printLog' :: LogLevel -> LogContext -> LogLevel -> PP.Doc () -> IO ()
161+
printLog' logLevelSetting msgCtx msgLogLvl msg =
162+
when (logLevelSetting >= msgLogLvl) $ putStrLn target
163+
where
164+
target =
165+
Render.renderString . layoutPretty defaultLayoutOptions $
166+
pretty msgCtx <+> pretty msgLogLvl <+> msg
167+
168+
-- | Reinterpret contract logs to be handled by PABEffect later down the line.
169+
handleContractLog :: forall w a effs. Member (PABEffect w) effs => Pretty a => Eff (LogMsg a ': effs) ~> Eff effs
170+
handleContractLog x = subsume $ handleContractLogInternal @w x
171+
172+
handleContractLogInternal :: forall w a effs. Pretty a => Eff (LogMsg a ': effs) ~> Eff (PABEffect w ': effs)
173+
handleContractLogInternal = reinterpret $ \case
174+
LMessage logMsg ->
175+
let msgContent = logMsg ^. Freer.logMessageContent
176+
msgLogLevel = toNativeLogLevel (logMsg ^. Freer.logLevel)
177+
msgPretty = pretty msgContent
178+
in printLog @w ContractLog msgLogLevel msgPretty
179+
where
180+
toNativeLogLevel Freer.Debug = Debug
181+
toNativeLogLevel Freer.Info = Info
182+
toNativeLogLevel Freer.Notice = Notice
183+
toNativeLogLevel Freer.Warning = Warn
184+
toNativeLogLevel Freer.Error = Error
185+
toNativeLogLevel Freer.Critical = Error
186+
toNativeLogLevel Freer.Alert = Error
187+
toNativeLogLevel Freer.Emergency = Error
154188

155189
callLocalCommand :: forall (a :: Type). ShellArgs a -> IO (Either Text a)
156190
callLocalCommand ShellArgs {cmdName, cmdArgs, cmdOutParser} =
@@ -221,12 +255,21 @@ createDirectoryIfMissingCLI ::
221255
createDirectoryIfMissingCLI createParents path = send @(PABEffect w) $ CreateDirectoryIfMissingCLI createParents path
222256

223257
printLog ::
258+
forall (w :: Type) (effs :: [Type -> Type]).
259+
Member (PABEffect w) effs =>
260+
LogContext ->
261+
LogLevel ->
262+
PP.Doc () ->
263+
Eff effs ()
264+
printLog logCtx logLevel msg = send @(PABEffect w) $ PrintLog logCtx logLevel msg
265+
266+
printBpiLog ::
224267
forall (w :: Type) (effs :: [Type -> Type]).
225268
Member (PABEffect w) effs =>
226269
LogLevel ->
227-
String ->
270+
PP.Doc () ->
228271
Eff effs ()
229-
printLog logLevel msg = send @(PABEffect w) $ PrintLog logLevel msg
272+
printBpiLog = printLog @w BpiLog
230273

231274
updateInstanceState ::
232275
forall (w :: Type) (effs :: [Type -> Type]). Member (PABEffect w) effs => Activity -> Eff effs ()

‎src/BotPlutusInterface/Types.hs‎

Lines changed: 19 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -7,6 +7,7 @@ module BotPlutusInterface.Types (
77
CLILocation (..),
88
AppState (AppState),
99
LogLevel (..),
10+
LogContext (..),
1011
ContractEnvironment (..),
1112
Tip (Tip, epoch, hash, slot, block, era, syncProgress),
1213
ContractState (..),
@@ -53,6 +54,7 @@ import Plutus.PAB.Effects.Contract.Builtin (
5354
SomeBuiltin (SomeBuiltin),
5455
endpointsToSchemas,
5556
)
57+
import Prettyprinter (Pretty (pretty))
5658
import Servant.Client (BaseUrl (BaseUrl), Scheme (Http))
5759
import Wallet.Types (ContractInstanceId (..))
5860
import Prelude
@@ -184,7 +186,23 @@ data CLILocation = Local | Remote Text
184186
deriving stock (Show, Eq)
185187

186188
data LogLevel = Error | Warn | Notice | Info | Debug
187-
deriving stock (Eq, Ord, Show)
189+
deriving stock (Bounded, Enum, Eq, Ord, Show)
190+
191+
instance Pretty LogLevel where
192+
pretty = \case
193+
Debug -> "[DEBUG]"
194+
Info -> "[INFO]"
195+
Notice -> "[NOTICE]"
196+
Warn -> "[WARNING]"
197+
Error -> "[ERROR]"
198+
199+
data LogContext = BpiLog | ContractLog
200+
deriving stock (Bounded, Enum, Eq, Ord, Show)
201+
202+
instance Pretty LogContext where
203+
pretty = \case
204+
BpiLog -> "[BPI]"
205+
ContractLog -> "[CONTRACT]"
188206

189207
instance Default PABConfig where
190208
def =

0 commit comments

Comments
 (0)