diff --git a/src/Chainweb/Pact/PactService.hs b/src/Chainweb/Pact/PactService.hs index f32b117b5f..5bffa73c1b 100644 --- a/src/Chainweb/Pact/PactService.hs +++ b/src/Chainweb/Pact/PactService.hs @@ -801,8 +801,8 @@ execLocal cwtx preflight sigVerify rdepth = pactLabel "execLocal" $ do , _crEvents = [] } in case preflight of - Just PreflightSimulation -> return $ LocalResultWithWarns parseError [] - _ -> return $ LocalResultLegacy parseError + Just PreflightSimulation -> return $ Pact4LocalResultWithWarns parseError [] + _ -> return $ Pact4LocalResultLegacy parseError Right pact4Cwtx -> do -- @@ -823,8 +823,8 @@ execLocal cwtx preflight sigVerify rdepth = pactLabel "execLocal" $ do let cr' = hashPact4TxLogs cr warns' = Pact4.renderCompactText <$> toList warns - pure $ LocalResultWithWarns cr' warns' - Left e -> pure $ MetadataValidationFailure e + pure $ Pact4LocalResultWithWarns cr' warns' + Left e -> pure $ review _MetadataValidationFailure e _ -> liftIO $ do let execConfig = Pact4.mkExecutionConfig $ [ Pact4.FlagAllowReadInLocal | _psAllowReadsInLocal ] ++ @@ -838,12 +838,12 @@ execLocal cwtx preflight sigVerify rdepth = pactLabel "execLocal" $ do pact4Cwtx mc execConfig let cr' = hashPact4TxLogs cr - pure $ LocalResultLegacy cr' + pure $ Pact4LocalResultLegacy cr' ) (do ph <- view psParentHeader case Pact5.parsePact4Command cwtx of Left (fmap Pact5.spanInfoToLineInfo -> parseError) -> - return $ LocalPact5PreflightResult Pact5.CommandResult + return $ Pact5LocalResultLegacy Pact5.CommandResult { _crReqKey = Pact5.RequestKey (Pact5.Hash $ Pact4.unHash $ Pact4.toUntypedHash $ Pact4._cmdHash cwtx) , _crTxId = Nothing , _crResult = Pact5.PactResultErr $ Pact5.PELegacyError $ Pact5.toPrettyLegacyError parseError @@ -853,14 +853,13 @@ execLocal cwtx preflight sigVerify rdepth = pactLabel "execLocal" $ do , _crMetaData = Nothing , _crEvents = [] } - [] Right pact5Cmd -> do let txCtx = Pact5.TxContext ph noMiner let spvSupport = Pact5.pactSPV bhdb (_parentHeader ph) case preflight of Just PreflightSimulation -> Pact5.liftPactServiceM (Pact5.assertLocalMetadata (view Pact5.payloadObj <$> pact5Cmd) txCtx sigVerify) >>= \case - Left e -> pure $ MetadataValidationFailure e + Left e -> pure $ review _MetadataValidationFailure e Right () -> do let initialGas = Pact5.initialGasOf $ Pact5._cmdPayload pact5Cmd Pact5.pactTransaction Nothing (\dbEnv -> @@ -869,7 +868,7 @@ execLocal cwtx preflight sigVerify rdepth = pactLabel "execLocal" $ do txCtx spvSupport initialGas (view Pact5.payloadObj <$> pact5Cmd) ) >>= \case Left err -> - return $ LocalPact5PreflightResult Pact5.CommandResult + return $ 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 @@ -885,11 +884,13 @@ execLocal cwtx preflight sigVerify rdepth = pactLabel "execLocal" $ do Right cr -> do let cr' = hashPact5TxLogs cr -- FIXME: Pact5, no warnings yet - pure $ LocalPact5PreflightResult (Pact5.PELegacyError . Pact5.toPrettyLegacyError <$> cr') [] + pure $ Pact5LocalResultWithWarns + (Pact5.PELegacyError . Pact5.toPrettyLegacyError <$> cr') + [] _ -> do cr <- Pact5.pactTransaction Nothing $ \dbEnv -> do fmap convertPact5Error <$> Pact5.applyLocal _psLogger _psGasLogger dbEnv txCtx spvSupport (view Pact5.payloadObj <$> pact5Cmd) - pure $ LocalPact5ResultLegacy (hashPact5TxLogs cr) + pure $ Pact5LocalResultLegacy (hashPact5TxLogs cr) ) @@ -899,7 +900,7 @@ execLocal cwtx preflight sigVerify rdepth = pactLabel "execLocal" $ do Just r -> pure r Nothing -> do logError_ _psLogger $ "Local action timed out for cwtx:\n" <> sshow cwtx - pure LocalTimeout + pure $ review _LocalTimeout () execSyncToBlock :: (CanReadablePayloadCas tbl, Logger logger) diff --git a/src/Chainweb/Pact/RestAPI/Server.hs b/src/Chainweb/Pact/RestAPI/Server.hs index 251d5582a3..31c82da1a0 100644 --- a/src/Chainweb/Pact/RestAPI/Server.hs +++ b/src/Chainweb/Pact/RestAPI/Server.hs @@ -390,7 +390,7 @@ localHandler logger pact preflight sigVerify rewindDepth cmd = do case r of Left (err :: PactException) -> throwError $ setErrText ("Execution failed: " <> T.pack (show err)) err400 - Right (MetadataValidationFailure e) -> do + Right (preview _MetadataValidationFailure -> Just e) -> do throwError $ setErrText ("Metadata validation failed: " <> decodeUtf8 (BSL.toStrict (Aeson.encode e))) err400 Right lr -> return $! lr diff --git a/src/Chainweb/Pact/Types.hs b/src/Chainweb/Pact/Types.hs index b3bacc5077..fe52abfd2a 100644 --- a/src/Chainweb/Pact/Types.hs +++ b/src/Chainweb/Pact/Types.hs @@ -10,6 +10,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -21,6 +22,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE ViewPatterns #-} -- | -- Module: Chainweb.Pact.Types -- Copyright: Copyright © 2018 Kadena LLC. @@ -81,15 +83,21 @@ module Chainweb.Pact.Types , SubmittedRequestMsg(..) , ValidateBlockReq(..) , RewindDepth(..) - , LocalResult(..) - , LocalReq(..) - , ReadOnlyReplayReq(..) - , ConfirmationDepth(..) - , LocalPreflightSimulation(..) + , LocalResult , _MetadataValidationFailure , _LocalResultWithWarns , _LocalResultLegacy , _LocalTimeout + , pattern Pact4LocalResultLegacy + , _Pact4LocalResultLegacy + , pattern Pact5LocalResultLegacy + , _Pact5LocalResultLegacy + , pattern Pact4LocalResultWithWarns + , pattern Pact5LocalResultWithWarns + , LocalReq(..) + , ReadOnlyReplayReq(..) + , ConfirmationDepth(..) + , LocalPreflightSimulation(..) , SyncToBlockReq(..) , RequestMsg(..) , RewindLimit(..) @@ -251,6 +259,9 @@ import qualified Data.Vector as V import qualified Pact.Core.Hash as Pact5 import Data.Maybe import Chainweb.BlockCreationTime +import qualified Data.Aeson as Aeson +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL -- | Gather tx logs for a block, along with last tx for each @@ -770,15 +781,66 @@ data LocalPreflightSimulation deriving stock (Eq, Show, Generic) -- | The type of local results (used in /local endpoint) +-- Internally contains a JsonText instead of a CommandResult for compatibility across Pact versions, +-- but the constructors are hidden. +-- This can be undone in the 2.28 release. -- data LocalResult = MetadataValidationFailure !(NE.NonEmpty Text) - | LocalResultWithWarns !(Pact4.CommandResult Pact4.Hash) ![Text] - | LocalResultLegacy !(Pact4.CommandResult Pact4.Hash) - | LocalPact5ResultLegacy !(Pact5.CommandResult Pact5.Hash (Pact5.PactErrorCompat (Pact5.LocatedErrorInfo Pact5.Info))) - | LocalPact5PreflightResult !(Pact5.CommandResult Pact5.Hash (Pact5.PactErrorCompat (Pact5.LocatedErrorInfo Pact5.Info))) ![Text] + | LocalResultLegacy !J.JsonText + | LocalResultWithWarns !J.JsonText ![Text] | LocalTimeout - deriving stock (Show, Generic) + deriving stock (Generic) + +pattern ConvertLocalResultLegacy :: (FromJSON a, J.Encode a) => a -> LocalResult +pattern ConvertLocalResultLegacy cr <- LocalResultLegacy (Aeson.decode . TL.encodeUtf8 . TL.fromStrict . J.getJsonText -> Just cr) where + ConvertLocalResultLegacy cr = LocalResultLegacy (J.encodeJsonText cr) + +pattern Pact4LocalResultLegacy + :: Pact4.CommandResult Pact4.Hash + -> LocalResult +pattern Pact4LocalResultLegacy cr <- ConvertLocalResultLegacy cr where + Pact4LocalResultLegacy cr = ConvertLocalResultLegacy cr +_Pact4LocalResultLegacy :: Prism' LocalResult (Pact4.CommandResult Pact4.Hash) +_Pact4LocalResultLegacy = prism' Pact4LocalResultLegacy $ \case + Pact4LocalResultLegacy cr -> Just cr + _ -> Nothing + +pattern Pact5LocalResultLegacy + :: Pact5.CommandResult Pact5.Hash (Pact5.PactErrorCompat (Pact5.LocatedErrorInfo Pact5.Info)) + -> LocalResult +pattern Pact5LocalResultLegacy cr <- ConvertLocalResultLegacy cr where + Pact5LocalResultLegacy cr = ConvertLocalResultLegacy cr +_Pact5LocalResultLegacy :: Prism' LocalResult (Pact5.CommandResult Pact5.Hash (Pact5.PactErrorCompat (Pact5.LocatedErrorInfo Pact5.Info))) +_Pact5LocalResultLegacy = prism' Pact5LocalResultLegacy $ \case + Pact5LocalResultLegacy cr -> Just cr + _ -> Nothing + +pattern ConvertLocalResultWithWarns :: (FromJSON a, J.Encode a) => a -> [Text] -> LocalResult +pattern ConvertLocalResultWithWarns cr warns <- LocalResultWithWarns (Aeson.decode . TL.encodeUtf8 . TL.fromStrict . J.getJsonText -> Just cr) warns where + ConvertLocalResultWithWarns cr warns = LocalResultWithWarns (J.encodeJsonText cr) warns + +pattern Pact4LocalResultWithWarns + :: Pact4.CommandResult Pact4.Hash + -> [Text] + -> LocalResult +pattern Pact4LocalResultWithWarns cr warns <- ConvertLocalResultWithWarns cr warns where + Pact4LocalResultWithWarns cr warns = ConvertLocalResultWithWarns cr warns +_Pact4LocalResultWithWarns :: Prism' LocalResult (Pact4.CommandResult Pact4.Hash, [Text]) +_Pact4LocalResultWithWarns = prism' (uncurry Pact4LocalResultWithWarns) $ \case + Pact4LocalResultWithWarns cr warns -> Just (cr, warns) + _ -> Nothing + +pattern Pact5LocalResultWithWarns + :: Pact5.CommandResult Pact5.Hash (Pact5.PactErrorCompat (Pact5.LocatedErrorInfo Pact5.Info)) + -> [Text] + -> LocalResult +pattern Pact5LocalResultWithWarns cr warns <- ConvertLocalResultWithWarns cr warns where + Pact5LocalResultWithWarns cr warns = ConvertLocalResultWithWarns cr warns +_Pact5LocalResultWithWarns :: Prism' LocalResult (Pact5.CommandResult Pact5.Hash (Pact5.PactErrorCompat (Pact5.LocatedErrorInfo Pact5.Info)), [Text]) +_Pact5LocalResultWithWarns = prism' (uncurry Pact5LocalResultWithWarns) $ \case + Pact5LocalResultWithWarns cr warns -> Just (cr, warns) + _ -> Nothing makePrisms ''LocalResult @@ -787,15 +849,10 @@ instance J.Encode LocalResult where [ "preflightValidationFailures" J..= J.Array (J.text <$> e) ] build (LocalResultLegacy cr) = J.build cr - build (LocalPact5ResultLegacy cr) = J.build cr build (LocalResultWithWarns cr ws) = J.object [ "preflightResult" J..= cr , "preflightWarnings" J..= J.Array (J.text <$> ws) ] - build (LocalPact5PreflightResult cr ws) = J.object - [ "preflightResult" J..= fmap (sshow @_ @Text) cr - , "preflightWarnings" J..= J.Array (J.text <$> ws) - ] build LocalTimeout = J.text "Transaction timed out" {-# INLINE build #-} @@ -807,18 +864,19 @@ instance FromJSON LocalResult where v <|> withObject "LocalResult" - (\o -> metaFailureParser o - <|> localWithWarnParser o - <|> legacyFallbackParser o + (\o -> + metaFailureParser o + <|> localWithWarnParser o + <|> pure (legacyFallbackParser o) ) v where metaFailureParser o = MetadataValidationFailure <$> o .: "preflightValidationFailure" localWithWarnParser o = LocalResultWithWarns - <$> o .: "preflightResult" + <$> (J.encodeJsonText @Value <$> o .: "preflightResult") <*> o .: "preflightWarnings" - legacyFallbackParser _ = LocalResultLegacy <$> parseJSON v + legacyFallbackParser _ = LocalResultLegacy $ J.encodeJsonText v -- | Used in tests for matching on JSON serialized pact exceptions diff --git a/test/lib/Chainweb/Test/RestAPI/Utils.hs b/test/lib/Chainweb/Test/RestAPI/Utils.hs index 1d6add486e..31d357eecb 100644 --- a/test/lib/Chainweb/Test/RestAPI/Utils.hs +++ b/test/lib/Chainweb/Test/RestAPI/Utils.hs @@ -83,6 +83,9 @@ import Pact.Types.Hash import qualified Pact.Core.Command.Server as Pact5 import qualified Pact.Core.Command.Types as Pact5 import qualified Pact.Types.API as Pact4 +import qualified Data.Aeson as Aeson +import qualified Data.Text.Lazy.Encoding as TL +import qualified Data.Text.Lazy as TL -- ------------------------------------------------------------------ -- -- Defaults @@ -153,9 +156,11 @@ local -> Command Text -> IO (CommandResult Hash) local v sid cenv cmd = do - LocalResultLegacy cr <- + Just cr <- preview _LocalResultLegacy <$> localWithQueryParams v sid cenv Nothing Nothing Nothing cmd - pure cr + Just pact4Cr <- return $ + Aeson.decode (TL.encodeUtf8 $ TL.fromStrict $ J.getJsonText cr) + pure pact4Cr localTestToRetry :: ChainwebVersion diff --git a/test/unit/Chainweb/Test/Pact4/PactExec.hs b/test/unit/Chainweb/Test/Pact4/PactExec.hs index 4d515828da..a00a97582a 100644 --- a/test/unit/Chainweb/Test/Pact4/PactExec.hs +++ b/test/unit/Chainweb/Test/Pact4/PactExec.hs @@ -7,6 +7,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} -- | -- Module: Chainweb.Test.Pact @@ -70,6 +71,9 @@ import Pact.Types.Pretty import qualified Pact.JSON.Encode as J import Data.Functor.Product +import qualified Data.Aeson as Aeson +import qualified Data.Text.Lazy.Encoding as TL +import qualified Data.Text.Lazy as TL testVersion :: ChainwebVersion testVersion = slowForkingCpmTestVersion petersonChainGraph @@ -572,14 +576,19 @@ execLocalTest runPact name (trans',check) = testCase name (go >>= check) results' <- tryAny $ runPact $ execLocal (Pact4.unparseTransaction trans) Nothing Nothing Nothing case results' of - Right (MetadataValidationFailure e) -> + Right (preview _MetadataValidationFailure -> Just e) -> + return $ Left $ show e + Right (preview _LocalTimeout -> Just ()) -> + return $ Left "LocalTimeout" + Right (preview _LocalResultLegacy -> Just cr) -> do + Just decodedCr <- return $ Aeson.decode (TL.encodeUtf8 $ TL.fromStrict $ J.getJsonText cr) + return $ Right decodedCr + Right (preview _LocalResultWithWarns -> Just (cr, _)) -> do + Just decodedCr <- return $ Aeson.decode (TL.encodeUtf8 $ TL.fromStrict $ J.getJsonText cr) + return $ Right decodedCr + Right _ -> error "unknown local result" + Left e -> return $ Left $ show e - Right LocalTimeout -> return $ Left "LocalTimeout" - Right (LocalResultLegacy cr) -> return $ Right cr - Right (LocalResultWithWarns cr _) -> return $ Right cr - Right (LocalPact5PreflightResult _ _) -> error "Pact 5" - Right (LocalPact5ResultLegacy _) -> error "Pact 5" - Left e -> return $ Left $ show e getPactCode :: TestSource -> IO Text getPactCode (Code str) = return (pack str) diff --git a/test/unit/Chainweb/Test/Pact4/PactMultiChainTest.hs b/test/unit/Chainweb/Test/Pact4/PactMultiChainTest.hs index 6ed782b989..8cc45de8b2 100644 --- a/test/unit/Chainweb/Test/Pact4/PactMultiChainTest.hs +++ b/test/unit/Chainweb/Test/Pact4/PactMultiChainTest.hs @@ -7,6 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} module Chainweb.Test.Pact4.PactMultiChainTest ( tests @@ -303,31 +304,42 @@ pactLocalDepthTest = do assertTxGas "Coin post-fork" 1574 ] - runLocalWithDepth "0" (Just $ RewindDepth 0) cid getSender00Balance >>= \r -> - checkLocalResult r $ assertTxSuccess "Should get the current balance" (pDecimal 99_999_997.6852) + runLocalWithDepth "0" (Just $ RewindDepth 0) cid getSender00Balance >>= \case + Right (Pact4LocalResultLegacy r) -> assertTxSuccess "Should get the current balance" (pDecimal 99_999_997.6852) r + _ -> error "bad" -- checking that `Just $ RewindDepth 0` has the same behaviour as `Nothing` - runLocalWithDepth "1" Nothing cid getSender00Balance >>= \r -> - checkLocalResult r $ assertTxSuccess "Should get the current balance as well" (pDecimal 99_999_997.6852) + runLocalWithDepth "1" Nothing cid getSender00Balance >>= \case + Right (Pact4LocalResultLegacy r) -> + assertTxSuccess "Should get the current balance as well" (pDecimal 99_999_997.6852) r + _ -> error "bad" - runLocalWithDepth "2" (Just $ RewindDepth 1) cid getSender00Balance >>= \r -> - checkLocalResult r $ assertTxSuccess "Should get the balance one block before" (pDecimal 99_999_998.8426) + runLocalWithDepth "2" (Just $ RewindDepth 1) cid getSender00Balance >>= \case + Right (Pact4LocalResultLegacy r) -> + assertTxSuccess "Should get the balance one block before" (pDecimal 99_999_998.8426) r + _ -> error "bad" - runLocalWithDepth "3" (Just $ RewindDepth 2) cid getSender00Balance >>= \r -> - checkLocalResult r $ assertTxSuccess "Should get the balance two blocks before" (pDecimal 100_000_000) + runLocalWithDepth "3" (Just $ RewindDepth 2) cid getSender00Balance >>= \case + Right (Pact4LocalResultLegacy r) -> + assertTxSuccess "Should get the balance two blocks before" (pDecimal 100_000_000) r + _ -> error "bad" -- the genesis depth - runLocalWithDepth "5" (Just $ RewindDepth 55) cid getSender00Balance >>= \r -> - checkLocalResult r $ assertTxSuccess "Should get the balance at the genesis block" (pDecimal 100000000) + runLocalWithDepth "5" (Just $ RewindDepth 55) cid getSender00Balance >>= \case + Right (Pact4LocalResultLegacy r) -> + assertTxSuccess "Should get the balance at the genesis block" (pDecimal 100000000) r + _ -> error "bad" -- local rewinding past genesis should be the same as rewinding to genesis - runLocalWithDepth "6" (Just $ RewindDepth 56) cid getSender00Balance >>= \r -> - checkLocalResult r $ assertTxSuccess "Should get the balance at the genesis block" (pDecimal 100000000) + runLocalWithDepth "6" (Just $ RewindDepth 56) cid getSender00Balance >>= \case + Right (Pact4LocalResultLegacy r) -> + assertTxSuccess "Should get the balance at the genesis block" (pDecimal 100000000) r + _ -> error "bad" where - checkLocalResult r checkResult = case r of - Right (LocalResultLegacy cr) -> checkResult cr - res -> liftIO $ assertFailure $ "Expected LocalResultLegacy, but got: " ++ show res + -- checkLocalResult r checkResult = case r of + -- Right (preview _LocalResultLegacy -> Just cr) -> checkResult cr + -- res -> liftIO $ assertFailure $ "Expected LocalResultLegacy, but got: " ++ show res getSender00Balance = set cbGasLimit 700 $ set cbRPC (mkExec' "(coin.get-balance \"sender00\")") $ defaultCmd buildCoinXfer code = buildBasic' (set cbSigners [mkEd25519Signer' sender00 coinCaps] . set cbGasLimit 3000) @@ -416,7 +428,7 @@ assertLocalFailure -> m () assertLocalFailure s d lr = liftIO $ assertEqual s (Just d) $ - lr ^? _Right . _LocalResultLegacy . crResult . to _pactResult . _Left . to peDoc + lr ^? _Right . _Pact4LocalResultLegacy . crResult . to _pactResult . _Left . to peDoc assertLocalSuccess :: (HasCallStack, MonadIO m) @@ -426,7 +438,7 @@ assertLocalSuccess -> m () assertLocalSuccess s pv lr = liftIO $ assertEqual s (Just pv) $ - lr ^? _Right . _LocalResultLegacy . crResult . to _pactResult . _Right + lr ^? _Right . _Pact4LocalResultLegacy . crResult . to _pactResult . _Right pact43UpgradeTest :: PactTestM () pact43UpgradeTest = do diff --git a/test/unit/Chainweb/Test/Pact4/RemotePactTest.hs b/test/unit/Chainweb/Test/Pact4/RemotePactTest.hs index 5f1baac931..21d7cdc57d 100644 --- a/test/unit/Chainweb/Test/Pact4/RemotePactTest.hs +++ b/test/unit/Chainweb/Test/Pact4/RemotePactTest.hs @@ -9,6 +9,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} -- | -- Module: Chainweb.Test.RemotePactTest @@ -664,18 +665,9 @@ localPreflightSimTest t cenv step = do psigs <- testKeyPairs sender00 Nothing cmd0 <- mkRawTx mv psid psigs runLocalPreflightClient sid cenv cmd0 >>= \case + Right Pact4LocalResultWithWarns{} -> pure () + Right r -> assertFailure $ "unexpected local result: " <> T.unpack (J.getJsonText $ J.encodeJsonText r) Left e -> assertFailure $ show e - Right LocalResultLegacy{} -> - assertFailure "Preflight /local call produced legacy result" - Right MetadataValidationFailure{} -> - assertFailure "Preflight produced an impossible result" - Right LocalTimeout -> - assertFailure "Preflight should never produce a timeout" - Right LocalResultWithWarns{} -> pure () - Right LocalPact5PreflightResult{} -> - assertFailure "Preflight /local call produced Pact5 result in Pact4-only tests" - Right (LocalPact5ResultLegacy _) -> - assertFailure "Preflight /local call produced Pact5 result in Pact4-only tests" step "Execute preflight /local tx - preflight+signoverify known /send success" cmd0' <- mkRawTx mv psid psigs @@ -724,18 +716,7 @@ localPreflightSimTest t cenv step = do currentBlockHeight <- getCurrentBlockHeight v cenv sid runLocalPreflightClient sid cenv cmd7 >>= \case - Left e -> assertFailure $ show e - Right LocalResultLegacy{} -> - assertFailure "Preflight /local call produced legacy result" - Right LocalTimeout -> - assertFailure "Preflight should never produce a timeout" - Right MetadataValidationFailure{} -> - assertFailure "Preflight produced an impossible result" - Right LocalPact5PreflightResult{} -> - assertFailure "Preflight /local call produced Pact5 result in Pact4-only tests" - Right (LocalPact5ResultLegacy _) -> - assertFailure "Preflight /local call produced Pact5 result in Pact4-only tests" - Right (LocalResultWithWarns cr' ws) -> do + Right (Pact4LocalResultWithWarns cr' ws) -> do let crbh :: Integer = fromIntegral $ fromMaybe 0 $ crGetBlockHeight cr' expectedbh = 1 + fromIntegral currentBlockHeight assertBool "Preflight's metadata should have increment block height" @@ -747,22 +728,13 @@ localPreflightSimTest t cenv step = do [w] | "decimal/integer operator overload" `T.isInfixOf` w -> pure () ws' -> assertFailure $ "Incorrect warns: " ++ show ws' + Right r -> assertFailure $ "invalid local result: " <> T.unpack (J.getJsonText $ J.encodeJsonText r) + Left e -> assertFailure $ show e let rewindDepth = 10 currentBlockHeight' <- getCurrentBlockHeight v cenv sid runLocalPreflightClientWithDepth sid cenv cmd7 rewindDepth >>= \case - Left e -> assertFailure $ show e - Right LocalResultLegacy{} -> - assertFailure "Preflight /local call produced legacy result" - Right LocalTimeout -> - assertFailure "Preflight should never produce a timeout" - Right MetadataValidationFailure{} -> - assertFailure "Preflight produced an impossible result" - Right LocalPact5PreflightResult{} -> - assertFailure "Preflight /local call produced Pact5 result in Pact4-only tests" - Right (LocalPact5ResultLegacy _) -> - assertFailure "Preflight /local call produced Pact5 result in Pact4-only tests" - Right (LocalResultWithWarns cr' ws) -> do + Right (Pact4LocalResultWithWarns cr' ws) -> do let crbh :: Integer = fromIntegral $ fromMaybe 0 $ crGetBlockHeight cr' expectedbh = toInteger $ 1 + (fromIntegral currentBlockHeight') - rewindDepth assertBool "Preflight's metadata block height should reflect the rewind depth" @@ -774,6 +746,8 @@ localPreflightSimTest t cenv step = do [w] | "decimal/integer operator overload" `T.isInfixOf` w -> pure () ws' -> assertFailure $ "Incorrect warns: " ++ show ws' + Right r -> assertFailure $ "invalid local result: " <> T.unpack (J.getJsonText $ J.encodeJsonText r) + Left e -> assertFailure $ show e where runLocalPreflightClient sid e cmd = flip runClientM e $ pactLocalWithQueryApiClient v sid @@ -788,7 +762,7 @@ localPreflightSimTest t cenv step = do runClientFailureAssertion sid e cmd msg = runLocalPreflightClient sid e cmd >>= \case Left err -> checkClientErrText err msg - r -> assertFailure $ "Unintended success: " ++ show r + r -> assertFailure $ "Unintended success: " ++ either show (T.unpack . J.getJsonText . J.encodeJsonText) r checkClientErrText (FailureResponse _ (Response _ _ _ body)) e | BS.isInfixOf e $ LBS.toStrict body = pure ()