better gas purchase failure error messages

Change-Id: Ic82ca99da0becbddb0f5242da4587542834695f3

src/Chainweb/Miner/Pact.hs

@@ -62,7 +62,7 @@ import Chainweb.Payload
 import Chainweb.Utils
 
 import qualified Pact.JSON.Encode as J
-import qualified Pact.Types.KeySet as Pact5
+import qualified Pact.Types.KeySet as Pact4
 
 -- -------------------------------------------------------------------------- --
 -- Miner data
@@ -77,7 +77,7 @@ newtype MinerId = MinerId { _minerId :: Text }
 -- | `MinerKeys` are a thin wrapper around a Pact `KeySet` to differentiate it
 -- from user keysets.
 --
-newtype MinerKeys = MinerKeys Pact5.KeySet
+newtype MinerKeys = MinerKeys Pact4.KeySet
     deriving stock (Eq, Ord, Generic)
     deriving newtype (Show, NFData)
 
@@ -97,15 +97,15 @@ data Miner = Miner !MinerId !MinerKeys
 instance J.Encode Miner where
     build (Miner (MinerId m) (MinerKeys ks)) = J.object
         [ "account" J..= m
-        , "predicate" J..= Pact5._ksPredFun ks
-        , "public-keys" J..= J.Array (Pact5._ksKeys ks)
+        , "predicate" J..= Pact4._ksPredFun ks
+        , "public-keys" J..= J.Array (Pact4._ksKeys ks)
         ]
     {-# INLINE build #-}
 
 instance FromJSON Miner where
     parseJSON = withObject "Miner" $ \o -> Miner
         <$> (MinerId <$> o .: "account")
-        <*> (MinerKeys <$> (Pact5.KeySet <$> o .: "public-keys" <*> o .: "predicate"))
+        <*> (MinerKeys <$> (Pact4.KeySet <$> o .: "public-keys" <*> o .: "predicate"))
 
 -- | A lens into the miner id of a miner.
 --
@@ -125,7 +125,7 @@ minerKeys = lens (\(Miner _ k) -> k) (\(Miner i _) b -> Miner i b)
 defaultMiner :: Miner
 defaultMiner = Miner (MinerId "miner")
     $ MinerKeys
-    $ Pact5.mkKeySet
+    $ Pact4.mkKeySet
       ["f880a433d6e2a13a32b6169030f56245efdd8c1b8a5027e9ce98a88e886bef27"]
       "keys-all"
 
@@ -134,7 +134,7 @@ defaultMiner = Miner (MinerId "miner")
 -- | A trivial Miner.
 --
 noMiner :: Miner
-noMiner = Miner (MinerId "NoMiner") (MinerKeys $ Pact5.mkKeySet [] "<")
+noMiner = Miner (MinerId "NoMiner") (MinerKeys $ Pact4.mkKeySet [] "<")
 {-# NOINLINE noMiner #-}
 
 -- | Convert from Pact `Miner` to Chainweb `MinerData`.

src/Chainweb/Pact/PactService.hs

@@ -913,9 +913,8 @@ execLocal cwtx preflight sigVerify rdepth = pactLabel "execLocal" $ do
                                 earlyReturn $ Pact5LocalResultWithWarns Pact5.CommandResult
                                     { _crReqKey = Pact5.RequestKey (Pact5.Hash $ Pact4.unHash $ Pact4.toUntypedHash $ Pact4._cmdHash cwtx)
                                     , _crTxId = Nothing
-                                    -- FIXME: Pact5, make this nicer, the `sshow` makes for an ugly error
                                     , _crResult = Pact5.PactResultErr $ Pact5.PELegacyError $
-                                        Pact5.LegacyPactError Pact5.LegacyGasError "" [] ("Gas error: " <> sshow err)
+                                        Pact5.LegacyPactError Pact5.LegacyGasError "" [] (prettyPact5GasPurchaseFailure err)
                                     , _crGas = Pact5.Gas $ fromIntegral $ cmd ^. Pact4.cmdPayload . Pact4.pMeta . Pact4.pmGasLimit
                                     , _crLogs = Nothing
                                     , _crContinuation = Nothing
@@ -1236,7 +1235,11 @@ execPreInsertCheckReq txs = pactLabel "execPreInsertCheckReq" $ do
             -- by necessity
             gasEnv <- Pact5.mkTableGasEnv (Pact5.MilliGasLimit mempty) Pact5.GasLogsDisabled
             (tx <$) <$> Pact5.buyGas logger' gasEnv pactDb txCtx (view Pact5.payloadObj <$> tx)
-        either (throwError . InsertErrorBuyGas . sshow) (\_ -> pure ()) result
+        case result of
+            Left err -> do
+                throwError $ InsertErrorBuyGas $ prettyPact5GasPurchaseFailure $ BuyGasError (Pact5.cmdToRequestKey tx) err
+            Right _ -> do
+                pure ()
 
 execLookupPactTxs
     :: (CanReadablePayloadCas tbl, Logger logger)

src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs

@@ -305,7 +305,7 @@ continueBlock mpAccess blockInProgress = do
                   return (([Left (Pact5._cmdHash tx)], True), s)
                 Just (Left err) -> do
                   logFunctionText logger Debug $
-                    "applyCmd failed to buy gas " <> sshow err
+                    "applyCmd failed to buy gas: " <> prettyPact5GasPurchaseFailure err
                   ((as, timedOut), s') <- runStateT rest s
                   return ((Left (Pact5._cmdHash tx):as, timedOut), s')
                 Just (Right (a, s')) -> do

src/Chainweb/Pact/Types.hs

@@ -123,6 +123,7 @@ module Chainweb.Pact.Types
   , _BuyGasError
   , _RedeemGasError
   , _PurchaseGasTxTooBigForGasLimit
+  , prettyPact5GasPurchaseFailure
   , Transactions(..)
   , transactionPairs
   , transactionCoinbase
@@ -217,6 +218,7 @@ import System.LogLevel
 import qualified Pact.Core.Builtin as Pact5
 import qualified Pact.Core.Errors as Pact5
 import qualified Pact.Core.Evaluate as Pact5
+import qualified Pact.Core.Pretty as Pact5
 
 -- internal chainweb modules
 
@@ -341,6 +343,15 @@ data Pact5GasPurchaseFailure
   deriving stock (Eq, Show)
 makePrisms ''Pact5GasPurchaseFailure
 
+prettyPact5GasPurchaseFailure :: Pact5GasPurchaseFailure -> Text
+prettyPact5GasPurchaseFailure = \case
+  BuyGasError rk e -> sshow rk <> " Failed to buy gas: " <> case e of
+    BuyGasPactError err -> Pact5.renderText err
+    BuyGasMultipleGasPayerCaps -> "Multiple gas payer capabilities"
+  RedeemGasError rk e -> sshow rk <> " Failed to redeem gas: " <> case e of
+    RedeemGasPactError err -> Pact5.renderText err
+  PurchaseGasTxTooBigForGasLimit rk -> sshow rk <> " Failed to purchas gas: tx too big for gas limit"
+
 data Pact4GasPurchaseFailure = Pact4GasPurchaseFailure !TransactionHash !Pact4.PactError
   deriving (Eq, Show)
 

test/unit/Chainweb/Test/Pact5/RemotePactTest.hs

@@ -196,6 +196,7 @@ tests rdb = withResource' (evaluate httpManager >> evaluate cert) $ \_ ->
         , testCaseSteps "pollingMetadataTest" (pollingMetadataTest rdb)
         , testCaseSteps "allocationTest" (allocationTest rdb)
         , testCaseSteps "webAuthnSignatureTest" (webAuthnSignatureTest rdb)
+        , testCaseSteps "gasPurchaseFailureMessages" (gasPurchaseFailureMessages rdb)
         , localTests rdb
         ]
 
@@ -675,6 +676,48 @@ allocationTest rdb step = runResourceT $ do
                         , ("guard", (PGuard $ GKeySetRef (KeySetName "allocation02" Nothing)))
                         ]
 
+gasPurchaseFailureMessages :: RocksDb -> Step -> IO ()
+gasPurchaseFailureMessages rdb _step = runResourceT $ do
+    let v = pact5InstantCpmTestVersion petersonChainGraph
+    let cid = unsafeChainId 0
+    fx <- mkFixture v rdb
+
+    liftIO $ do
+        -- buyGas with insufficient balance to pay for the full supply
+        -- (gas price * gas limit) should return an error
+        -- this relies on sender00's starting balance.
+        do
+            cmd <- buildTextCmd v
+                $ set cbSender "sender00"
+                $ set cbSigners [mkEd25519Signer' sender00 []]
+                $ set cbGasPrice (GasPrice 70_000)
+                $ set cbGasLimit (GasLimit (Gas 100_000))
+                $ defaultCmd cid
+            send fx v cid [cmd]
+                & P.fails
+                ? P.match _FailureResponse
+                ? P.fun responseBody
+                ? textContains "Failed to buy gas: Insufficient funds"
+
+        -- multiple gas payer caps should lead to an error, because it's unclear
+        -- which module will pay for gas
+        do
+            cmd <- buildTextCmd v
+                $ set cbSender "sender00"
+                $ set cbSigners
+                    [ mkEd25519Signer' sender00
+                        [ CapToken (QualifiedName "GAS" (ModuleName "coin" Nothing)) []
+                        , CapToken (QualifiedName "GAS_PAYER" (ModuleName "coin" Nothing)) []
+                        , CapToken (QualifiedName "GAS_PAYER" (ModuleName "coin2" Nothing)) []
+                        ]
+                    ]
+                $ defaultCmd cid
+            send fx v cid [cmd]
+                & P.fails
+                ? P.match _FailureResponse
+                ? P.fun responseBody
+                ? textContains "Failed to buy gas: Multiple gas payer capabilities"
+
 successfulTx :: P.Prop (CommandResult log err)
 successfulTx = P.fun _crResult ? P.match _PactResultOk P.succeed
 

test/unit/Chainweb/Test/Pact5/TransactionExecTest.hs

@@ -17,7 +17,7 @@ module Chainweb.Test.Pact5.TransactionExecTest (tests) where
 
 import Chainweb.BlockHeader
 import Chainweb.Graph (singletonChainGraph, petersonChainGraph)
-import Chainweb.Miner.Pact (noMiner)
+import Chainweb.Miner.Pact (Miner(..), MinerId(..), MinerKeys(..), noMiner)
 import Chainweb.Pact.PactService (initialPayloadState, withPactService)
 import Chainweb.Pact.PactService.Checkpointer (readFrom, SomeBlockM(..))
 import Chainweb.Pact.Types
@@ -63,6 +63,7 @@ import Pact.Core.Persistence hiding (pactDb)
 import Pact.Core.SPV (noSPVSupport)
 import Pact.Core.Signer
 import Pact.Core.Verifiers
+import Pact.Types.KeySet qualified as Pact4
 import Pact.JSON.Encode qualified as J
 import PropertyMatchers ((?))
 import PropertyMatchers qualified as P
@@ -77,6 +78,8 @@ tests baseRdb = testGroup "Pact5 TransactionExecTest"
     [ testCase "buyGas should take gas tokens from the transaction sender" (buyGasShouldTakeGasTokensFromTheTransactionSender baseRdb)
     , testCase "buyGas failures" (buyGasFailures baseRdb)
     , testCase "redeem gas should give gas tokens to the transaction sender and miner" (redeemGasShouldGiveGasTokensToTheTransactionSenderAndMiner baseRdb)
+    , testCase "redeem gas failure" (redeemGasFailure baseRdb)
+    , testCase "purchase gas tx too big" (purchaseGasTxTooBig baseRdb)
     , testCase "run payload should return an EvalResult related to the input command" (runPayloadShouldReturnEvalResultRelatedToTheInputCommand baseRdb)
     , testCase "applyLocal spec" (applyLocalSpec baseRdb)
     , testCase "applyCmd spec" (applyCmdSpec baseRdb)
@@ -194,6 +197,47 @@ redeemGasShouldGiveGasTokensToTheTransactionSenderAndMiner rdb = readFromAfterGe
         endMinerBal <- readBal pactDb "NoMiner"
         assertEqual "miner balance after redeeming gas" (Just $ fromMaybe 0 startMinerBal + 3 * 2) endMinerBal
 
+redeemGasFailure :: RocksDb -> IO ()
+redeemGasFailure rdb = readFromAfterGenesis v rdb $ do
+    pactTransaction Nothing $ \pactDb -> do
+        let miner = Miner (MinerId "sender00")
+                $ MinerKeys
+                $ Pact4.mkKeySet
+                    [Pact4.PublicKeyText $ fst sender00]
+                    "keys-all"
+
+        cmd <- buildCwCmd v
+            $ set cbRPC (mkExec ("(coin.rotate \"sender00\" (read-keyset 'ks))") (mkKeySetData "ks" [sender01]))
+            $ set cbSigners
+                [ mkEd25519Signer' sender00
+                    [ CapToken (QualifiedName "GAS" (ModuleName "coin" Nothing)) []
+                    , CapToken (QualifiedName "ROTATE" (ModuleName "coin" Nothing)) [PString "sender00"]
+                    ]
+                ]
+            $ defaultCmd cid
+        let txCtx = TxContext {_tcParentHeader = ParentHeader (gh v cid), _tcMiner = miner}
+        logger <- testLogger
+        applyCmd logger Nothing pactDb txCtx noSPVSupport (Gas 1) (view payloadObj <$> cmd)
+            >>= P.match _Left
+            ? P.match (_RedeemGasError . _2 . _RedeemGasPactError)
+            ? P.match (_PEUserRecoverableError . _1)
+            ? P.equals (UserEnforceError "account guards do not match")
+
+purchaseGasTxTooBig :: RocksDb -> IO ()
+purchaseGasTxTooBig rdb = readFromAfterGenesis v rdb $ do
+    pactTransaction Nothing $ \pactDb -> do
+        cmd <- buildCwCmd v
+            $ set cbSender "sender00"
+            $ set cbSigners [mkEd25519Signer' sender00 []]
+            $ set cbGasLimit (GasLimit (Gas 1)) -- We set the gas limit to lower than the initialGas passed to applyCmd so that this test fails
+            $ defaultCmd cid
+        let txCtx = TxContext {_tcParentHeader = ParentHeader (gh v cid), _tcMiner = noMiner}
+        logger <- testLogger
+        applyCmd logger Nothing pactDb txCtx noSPVSupport (Gas 2) (view payloadObj <$> cmd)
+            >>= P.match _Left
+            ? P.match _PurchaseGasTxTooBigForGasLimit
+            ? P.succeed
+
 payloadFailureShouldPayAllGasToTheMinerTypeError :: RocksDb -> IO ()
 payloadFailureShouldPayAllGasToTheMinerTypeError rdb = readFromAfterGenesis v rdb $ do
     pactTransaction Nothing $ \pactDb -> do