Merge branch 'collateral-ignore' of github.com:ChaseAtMLabs/bot-plutus-interface into collateral-ignore

Author: TotallyNotChase

bot-plutus-interface.cabal

@@ -124,6 +124,7 @@ library
     , plutus-pab
     , plutus-tx
     , plutus-tx-plugin
+    , prettyprinter
     , process
     , QuickCheck
     , row-types
@@ -140,6 +141,7 @@ library
     , transformers-except
     , unordered-containers
     , uuid
+    , vector
     , wai
     , warp
     , websockets
@@ -193,6 +195,7 @@ test-suite bot-plutus-interface-test
     , plutus-pab
     , plutus-tx
     , plutus-tx-plugin
+    , prettyprinter
     , QuickCheck
     , quickcheck-instances
     , row-types

src/BotPlutusInterface/Balance.hs

@@ -8,7 +8,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)
@@ -61,6 +61,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
@@ -87,7 +88,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)
@@ -131,7 +132,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 <-
@@ -143,7 +144,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

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,12 +292,15 @@ 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) $
+      collectBudgetStats (Tx.txId tx) pabConf
+
     when (not pabConf.pcDryRun && signable) $ do
       newEitherT $ CardanoCLI.submitTx @w pabConf tx
 
@@ -284,9 +311,6 @@ writeBalancedTx contractEnv (Right tx) = do
     mvFiles (Files.txFilePath pabConf "raw" (Tx.txId tx)) (Files.txFilePath pabConf "raw" cardanoTxId)
     when signable $ mvFiles signedSrcPath signedDstPath
 
-    when contractEnv.cePABConfig.pcCollectStats $
-      collectBudgetStats cardanoTxId signedDstPath
-
     pure cardanoTx
   where
     mvFiles :: Text -> Text -> EitherT Text (Eff effs) ()
@@ -299,10 +323,17 @@ writeBalancedTx contractEnv (Right tx) = do
             , cmdOutParser = const ()
             }
 
-    collectBudgetStats txId txPath = do
-      let path = Text.unpack txPath
-      b <- firstEitherT (Text.pack . show) $ newEitherT $ estimateBudget @w (Signed path)
-      void $ newEitherT (Right <$> saveBudget @w txId b)
+    collectBudgetStats txId pabConf = do
+      let path = Text.unpack (Files.txFilePath pabConf "signed" (Tx.txId tx))
+      txBudget <-
+        firstEitherT toBudgetSaveError $
+          newEitherT $ estimateBudget @w (Signed path)
+      void $ newEitherT (Right <$> saveBudget @w txId txBudget)
+
+    toBudgetSaveError =
+      Text.pack
+        . ("Failed to save Tx budgets statistics: " ++)
+        . show
 
 pkhToText :: Ledger.PubKey -> Text
 pkhToText = encodeByteString . fromBuiltin . Ledger.getPubKeyHash . Ledger.pubKeyHash

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 ()

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 =