From 4a72c46cbd63f9f9f55b2a6255c8557e94a5fe54 Mon Sep 17 00:00:00 2001
From: Edmund Noble <edmundnoble@gmail.com>
Date: Wed, 22 Jan 2025 07:40:44 -0500
Subject: [PATCH] Move back to old Show PactException instance for Pact 4
 compat

Change-Id: Id0000000e1e52e6bd428c02038733e92c7704384
---
 src/Chainweb/Pact/Types.hs                    | 38 ++++++++++++++++++-
 .../Chainweb/Test/Pact4/RemotePactTest.hs     | 36 ++++++++++++++++++
 2 files changed, 73 insertions(+), 1 deletion(-)

diff --git a/src/Chainweb/Pact/Types.hs b/src/Chainweb/Pact/Types.hs
index 83ee7dd28..0f4d5dc7d 100644
--- a/src/Chainweb/Pact/Types.hs
+++ b/src/Chainweb/Pact/Types.hs
@@ -391,9 +391,45 @@ data PactException
     { _earliestBlockHeight :: !BlockHeight
     , _genesisHeight :: !BlockHeight
     }
-  deriving stock (Show, Generic)
+  deriving stock (Generic)
   deriving anyclass (Exception)
 
+instance Show PactException where
+    show = T.unpack . J.encodeText
+
+instance J.Encode PactException where
+  build (BlockValidationFailure msg) = tagged "BlockValidationFailure" msg
+  build (PactInternalError _stack msg) = tagged "PactInternalError" msg
+  build (PactTransactionExecError h msg) = tagged "PactTransactionExecError" (J.Array (h, msg))
+  build (CoinbaseFailure msg) = tagged "CoinbaseFailure" msg
+  build NoBlockValidatedYet = tagged "NoBlockValidatedYet" J.null
+  build (Pact4TransactionValidationException l) = tagged "TransactionValidationException" (J.Array $ J.Array <$> l)
+  build (Pact5TransactionValidationException l) = tagged "TransactionValidationException" (J.Array $ J.Array <$> l)
+  build (PactDuplicateTableError msg) = tagged "PactDuplicateTableError" msg
+  build (TransactionDecodeFailure msg) = tagged "TransactionDecodeFailure" msg
+  build o@(RewindLimitExceeded{}) = tagged "RewindLimitExceeded" $ J.object
+    [ "_rewindExceededLimit" J..= J.Aeson (_rewindLimit $ _rewindExceededLimit o)
+    , "_rewindExceededLast" J..= J.encodeWithAeson (ObjectEncoded <$> _rewindExceededLast o)
+    , "_rewindExceededTarget" J..= J.encodeWithAeson (ObjectEncoded <$> _rewindExceededTarget o)
+    ]
+  build (BlockHeaderLookupFailure msg) = tagged "BlockHeaderLookupFailure" msg
+  build (Pact4BuyGasFailure failure) = tagged "BuyGasFailure" failure
+  build (Pact5BuyGasFailure failure) = tagged "BuyGasFailure" (sshow @_ @Text failure)
+  build (MempoolFillFailure msg) = tagged "MempoolFillFailure" msg
+  build (Pact5GenesisCommandFailed hash text) = tagged "BlockGasLimitExceeded" (J.Array $ [sshow @_ @Text hash, text])
+  build (Pact5GenesisCommandsInvalid errs) = tagged "BlockGasLimitExceeded" (J.Array $ sshow @_ @Text <$> errs)
+  build (BlockGasLimitExceeded gas) = tagged "BlockGasLimitExceeded" gas
+  build o@(FullHistoryRequired{}) = tagged "FullHistoryRequired" $ J.object
+    [ "_fullHistoryRequiredEarliestBlockHeight" J..= J.Aeson @Int (fromIntegral $ _earliestBlockHeight o)
+    , "_fullHistoryRequiredGenesisHeight" J..= J.Aeson @Int (fromIntegral $ _genesisHeight o)
+    ]
+
+tagged :: J.Encode v => Text -> v -> J.Builder
+tagged t v = J.object
+    [ "tag" J..= t
+    , "contents" J..= v
+    ]
+
 instance Eq PactException where
   BlockValidationFailure m == BlockValidationFailure m' = m == m'
   PactInternalError _ m == PactInternalError _ m' = m == m'
diff --git a/test/unit/Chainweb/Test/Pact4/RemotePactTest.hs b/test/unit/Chainweb/Test/Pact4/RemotePactTest.hs
index 587768a6c..bc43440e7 100644
--- a/test/unit/Chainweb/Test/Pact4/RemotePactTest.hs
+++ b/test/unit/Chainweb/Test/Pact4/RemotePactTest.hs
@@ -193,6 +193,7 @@ tests rdb = testGroup "Chainweb.Test.Pact4.RemotePactTest"
             ]
       , testCase "txlogsCompactionTest" $ txlogsCompactionTest rdb
       , testCase "invalid command test" $ invalidCommandTest rdb
+      , testCase "db error test" $ dbErrorTest rdb
     ]
 
 responseGolden :: ClientEnv -> RequestKeys -> IO LBS.ByteString
@@ -202,6 +203,41 @@ responseGolden cenv rks = do
                           (NEL.toList $ _rkRequestKeys rks)
     return $ foldMap J.encode values
 
+-- this tests the exact content of dberrors which make it into outputs
+dbErrorTest :: RocksDb -> IO ()
+dbErrorTest rdb = runResourceT $ do
+    nodeDbDirs <- withNodeDbDirs rdb nNodes
+    net <- withNodesAtLatestBehavior v id nodeDbDirs
+    liftIO $ do
+      iot <- liftIO $ toTxCreationTime @Integer <$> getCurrentTimeIntegral
+      let cenv = _getServiceClientEnv net
+      cmd <- liftIO $ buildTextCmd "err" v
+          $ set cbSigners [mkEd25519Signer' sender00 []]
+          $ set cbTTL defaultMaxTTL
+          $ set cbCreationTime iot
+          $ set cbChainId cid
+          $ set cbGasLimit 70000
+          $ set cbRPC (mkExec
+            (T.unlines
+              [ "(namespace 'free)"
+              , "(module m G"
+              , "(defcap G () true)"
+              , "(defschema s i:integer)"
+              , "(deftable tbl:{s})"
+              , "(defun f () (update tbl 'x {'i: 4})))"
+              , "(create-table tbl)"
+              , "(f)"
+              ]
+              )
+            (mkKeySetData "sender00" [sender00]))
+          $ defaultCmd
+      let expectedMessage =
+            ": Failure: Database exception: {\"tag\":\"PactInternalError\",\"contents\":\"checkInsertIsOK: Update: no row found for key x\"}"
+      r <- local v cid cenv cmd
+      assertEqual "something"
+        (over _Left show $ _pactResult $ _crResult r)
+        (Left expectedMessage)
+
 invalidCommandTest :: RocksDb -> IO ()
 invalidCommandTest rdb = runResourceT $ do
     nodeDbDirs <- withNodeDbDirs rdb nNodes