merge master and fix tests

Author: IAmPara0x

bot-plutus-interface.cabal

@@ -220,6 +220,7 @@ test-suite bot-plutus-interface-test
     , plutus-pab
     , plutus-tx
     , plutus-tx-plugin
+    , pretty-diff
     , prettyprinter
     , QuickCheck
     , quickcheck-instances

src/BotPlutusInterface/Balance.hs

@@ -25,7 +25,7 @@ import BotPlutusInterface.Effects (
 import BotPlutusInterface.Files (DummyPrivKey, unDummyPrivateKey)
 import BotPlutusInterface.Files qualified as Files
 import BotPlutusInterface.Types (
-  CollateralUtxo,
+  CollateralUtxo (collateralTxOutRef),
   LogLevel (Debug),
   LogType (TxBalancingLog),
   PABConfig,

src/BotPlutusInterface/CoinSelection.hs

@@ -133,9 +133,7 @@ greedySearch stopSearch outVec txInsVec utxosVec
               zip [0 .. length utxosVec - 1] utxosDist
 
       newEitherT $ loop sortedDist txInsVec
-  
   where
-    
     loop :: [(Int, Float)] -> Vector Integer -> Eff effs (Either Text [Int])
     loop [] _ = return $ Right mempty
     loop ((idx, _) : remSortedDist) newTxInsVec =
@@ -176,27 +174,24 @@ greedyPruning stopSearch outVec txInsVec utxosVec
     runEitherT $ do
       selectedUtxosIdx <- newEitherT $ greedySearch @w stopSearch outVec txInsVec utxosVec
 
-      let revSelectedUtxosVec :: [Vector Integer] 
+      let revSelectedUtxosVec :: [Vector Integer]
           revSelectedUtxosVec = List.reverse $ mapMaybe (\idx -> utxosVec ^? ix idx) selectedUtxosIdx
 
           revSelectedUtxosIdx :: [Int]
           revSelectedUtxosIdx = List.reverse selectedUtxosIdx
 
       hoistEither $ loop txInsVec revSelectedUtxosIdx revSelectedUtxosVec
-     
   where
-    
     loop :: Vector Integer -> [Int] -> [Vector Integer] -> Either Text [Int]
-    loop newTxInsVec (idx:idxs) (vec:vecs) = do
-     newTxInsVec' <- addVec newTxInsVec vec
-     changeVec  <- subVec outVec newTxInsVec
-     changeVec' <- subVec outVec newTxInsVec'
-
-     case l2norm outVec changeVec' < l2norm outVec changeVec of
-       True   -> (idx :) <$> loop newTxInsVec' idxs vecs
-       False | stopSearch newTxInsVec -> Right mempty
-       False -> (idx :) <$> loop newTxInsVec' idxs vecs
-
+    loop newTxInsVec (idx : idxs) (vec : vecs) = do
+      newTxInsVec' <- addVec newTxInsVec vec
+      changeVec <- subVec outVec newTxInsVec
+      changeVec' <- subVec outVec newTxInsVec'
+
+      case l2norm outVec changeVec' < l2norm outVec changeVec of
+        True -> (idx :) <$> loop newTxInsVec' idxs vecs
+        False | stopSearch newTxInsVec -> Right mempty
+        False -> (idx :) <$> loop newTxInsVec' idxs vecs
     loop _newTxInsVec [] [] = pure mempty
     loop _newTxInsVec _idxs _vecs = Left "Length of idxs and list of vecs are not same."
 

src/BotPlutusInterface/Contract.hs

@@ -4,7 +4,7 @@
 
 module BotPlutusInterface.Contract (runContract, handleContract) where
 
-import BotPlutusInterface.Balance qualified as PreBalance
+import BotPlutusInterface.Balance qualified as Balance
 import BotPlutusInterface.BodyBuilder qualified as BodyBuilder
 import BotPlutusInterface.CardanoCLI qualified as CardanoCLI
 import BotPlutusInterface.Collateral qualified as Collateral
@@ -240,7 +240,7 @@ awaitTxStatusChange contractEnv txId = do
     txStatus <- getStatus
     case (txStatus, currBlock > cutOffBlock) of
       (status, True) -> do
-        helperLog (Debug [PABLog]) . mconcat . fmap mconcat $
+        helperLog . mconcat . fmap mconcat $
           [ ["Timeout for waiting `TxId ", show txId, "` status change reached"]
           , [" - waited ", show pollTimeout, " blocks."]
           , [" Current status: ", show status]
@@ -255,17 +255,17 @@ awaitTxStatusChange contractEnv txId = do
       mTx <- queryChainIndexForTxState
       case mTx of
         Nothing -> do
-          helperLog (Debug [PABLog]) $ "TxId " ++ show txId ++ " not found in index"
+          helperLog $ "TxId " ++ show txId ++ " not found in index"
           pure Unknown
         Just txState -> do
-          helperLog (Debug [PABLog]) $ "TxId " ++ show txId ++ " found in index, checking status"
+          helperLog $ "TxId " ++ show txId ++ " found in index, checking status"
           blk <- fromInteger <$> currentBlock contractEnv
           case transactionStatus blk txState txId of
             Left e -> do
-              helperLog (Debug [PABLog]) $ "Status check for TxId " ++ show txId ++ " failed with " ++ show e
+              helperLog $ "Status check for TxId " ++ show txId ++ " failed with " ++ show e
               pure Unknown
             Right st -> do
-              helperLog (Debug [PABLog]) $ "Status for TxId " ++ show txId ++ " is " ++ show st
+              helperLog $ "Status for TxId " ++ show txId ++ " is " ++ show st
               pure st
 
     queryChainIndexForTxState :: Eff effs (Maybe TxIdState)
@@ -277,8 +277,7 @@ awaitTxStatusChange contractEnv txId = do
           pure . Just $ fromTx blk tx
         Nothing -> pure Nothing
 
-    helperLog :: LogLevel -> String -> Eff effs ()
-    helperLog (Debug a) = printBpiLog @w (Debug a) . pretty
+    helperLog = printBpiLog @w (Debug [CollateralLog]) . pretty
 
 -- | This will FULLY balance a transaction
 balanceTx ::
@@ -296,21 +295,16 @@ balanceTx contractEnv unbalancedTx = do
     Left e -> pure $ BalanceTxFailed (OtherError e)
     _ -> do
       uploadDir @w pabConf.pcSigningKeyFileDir
-      eitherPreBalancedTx <-
-        if PreBalance.txUsesScripts (unBalancedTxTx unbalancedTx)
-          then
-            PreBalance.balanceTxIO' @w
-              PreBalance.defaultBalanceConfig {PreBalance.bcHasScripts = True}
-              pabConf
-              pabConf.pcOwnPubKeyHash
-              unbalancedTx
-          else
-            PreBalance.balanceTxIO @w
-              pabConf
-              pabConf.pcOwnPubKeyHash
-              unbalancedTx
-
-      pure $ either (BalanceTxFailed . InsufficientFunds) (BalanceTxSuccess . Right) eitherPreBalancedTx
+      eitherBalancedTx <-
+        Balance.balanceTxIO' @w
+          Balance.defaultBalanceConfig
+            { Balance.bcHasScripts = Balance.txUsesScripts (unBalancedTxTx unbalancedTx)
+            }
+          pabConf
+          pabConf.pcOwnPubKeyHash
+          unbalancedTx
+
+      pure $ either (BalanceTxFailed . InsufficientFunds) (BalanceTxSuccess . Right) eitherBalancedTx
 
 -- | This step would build tx files, write them to disk and submit them to the chain
 writeBalancedTx ::
@@ -485,7 +479,7 @@ handleCollateral cEnv = do
   case result of
     Right collteralUtxo ->
       setInMemCollateral @w collteralUtxo
-        >> Right <$> printBpiLog @w (Debug [PABLog]) "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
     --
@@ -510,8 +504,8 @@ makeCollateral cEnv = runEitherT $ do
 
   balancedTx <-
     newEitherT $
-      PreBalance.balanceTxIO' @w
-        PreBalance.defaultBalanceConfig {PreBalance.bcHasScripts = False, PreBalance.bcSeparateChange = True}
+      Balance.balanceTxIO' @w
+        Balance.defaultBalanceConfig {Balance.bcHasScripts = False, Balance.bcSeparateChange = True}
         pabConf
         pabConf.pcOwnPubKeyHash unbalancedTx
 

src/BotPlutusInterface/Effects.hs

@@ -44,7 +44,7 @@ import BotPlutusInterface.Types (
   ContractState (ContractState),
   LogContext (BpiLog, ContractLog),
   LogLevel (..),
-  LogType (AnyLog),
+  LogType (..),
   LogsList (LogsList),
   TxBudget,
   TxFile,
@@ -64,8 +64,8 @@ import Data.Aeson (ToJSON)
 import Data.Aeson qualified as JSON
 import Data.Bifunctor (second)
 import Data.ByteString qualified as ByteString
-import Data.List (intersect)
 import Data.Kind (Type)
+import Data.List (intersect)
 import Data.Maybe (catMaybes)
 import Data.String (IsString, fromString)
 import Data.Text (Text)
@@ -194,16 +194,16 @@ handlePABEffect contractEnv =
 printLog' :: LogLevel -> LogContext -> LogLevel -> PP.Doc () -> IO ()
 printLog' logLevelSetting msgCtx msgLogLvl msg =
   when
-    (logLevelSetting {ltLogTypes = mempty} >= msgLogLvl {ltLogTypes = mempty}
-      && not (null intersectLogTypes))
+    ( 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

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 (..),
@@ -261,11 +262,12 @@ instance Pretty LogType where
   pretty PABLog = "PABLog"
   pretty AnyLog = "Any"
 
-data LogLevel = Error { ltLogTypes :: [LogType] }
-              | Warn { ltLogTypes :: [LogType] }
-              | Notice { ltLogTypes :: [LogType] } 
-              | Info { ltLogTypes :: [LogType] }
-              | Debug { ltLogTypes :: [LogType] }
+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

src/PlutusConfig/Cardano/Api/Shelley.hs

@@ -20,6 +20,7 @@ import Config.Schema (
   naturalSpec,
   sectionsSpec,
  )
+import Control.Exception (IOException, catch)
 import Data.Aeson qualified as JSON
 import Data.ByteString.Lazy qualified as LazyByteString
 import Data.Default (def)
@@ -276,7 +277,7 @@ instance HasSpec ProtocolParameters where
     pure ProtocolParameters {..}
 
 readProtocolParametersJSON :: FilePath -> IO (Either String ProtocolParameters)
-readProtocolParametersJSON fn = JSON.eitherDecode <$> LazyByteString.readFile fn
+readProtocolParametersJSON fn = (JSON.eitherDecode <$> LazyByteString.readFile fn) `catch` (\(e :: IOException) -> pure $ Left (show e))
 
 writeProtocolParametersJSON :: FilePath -> ProtocolParameters -> IO ()
 writeProtocolParametersJSON fn params =

test/Spec/BotPlutusInterface/Balance.hs

@@ -88,7 +88,7 @@ addUtxosForNativeTokens = do
 
   case ebalancedTx of
     Left e -> assertFailure (Text.unpack e)
-    Right balancedTx -> txInputs <$> balancedTx @?= Right (Set.fromList [txIn1, txIn2, txIn3, txIn4])
+    Right balancedTx -> txInputs <$> balancedTx @?= Right (Set.fromList [txIn3, txIn4])
 
 addUtxosForChange :: Assertion
 addUtxosForChange = do

test/Spec/BotPlutusInterface/Contract.hs

@@ -45,6 +45,11 @@ import Plutus.Contract (
  )
 import PlutusTx qualified
 import PlutusTx.Builtins (fromBuiltin)
+import Pretty.Diff (
+  MultilineContext (FullContext),
+  Wrapping (Wrap),
+ )
+import Pretty.Diff qualified as Diff
 import Spec.MockContract (
   MockContractState (..),
   addr1,
@@ -903,7 +908,14 @@ assertCommandHistory state =
 assertCommandEqual :: String -> Text -> Text -> Assertion
 assertCommandEqual err expected actual
   | commandEqual expected actual = pure ()
-  | otherwise = assertFailure $ err ++ "\nExpected:\n" ++ show expected ++ "\nGot:\n" ++ show actual
+  | otherwise = assertFailure $ err ++ "\n" ++ prettyPrintDiff expected actual
+
+prettyPrintDiff :: Text -> Text -> String
+prettyPrintDiff expected actual =
+  "\nExpected:\n"
+    ++ Text.unpack (Diff.above (Wrap 80) FullContext (Text.replace "\n" " " expected) actual)
+    ++ "\nGot:\n"
+    ++ Text.unpack (Diff.below (Wrap 80) FullContext (Text.replace "\n" " " expected) actual)
 
 {- | Checks if a command matches an expected command pattern
  Where a command pattern may use new lines in place of spaces, and use the wildcard `?` to match up to the next space