From f38a8d52613cb875da8ba2af97898cf4b944916f Mon Sep 17 00:00:00 2001 From: Edmund Noble Date: Fri, 20 Dec 2024 16:07:34 -0500 Subject: [PATCH] Refactor `poll` and `send`, and add a new invalid tx test Renamed polling and sending to `poll` and `send`. Now also, both of them have more general types, for convenience. Request keys are no longer returned by `send`, because they can be computed by the caller. `send` and `poll` now also include assertions which are always useful to test. --- chainweb.cabal | 1 + .../Chainweb/Test/Pact5/RemotePactTest.hs | 307 ++++++++++-------- 2 files changed, 178 insertions(+), 130 deletions(-) diff --git a/chainweb.cabal b/chainweb.cabal index 57eac648a..60409ceba 100644 --- a/chainweb.cabal +++ b/chainweb.cabal @@ -725,6 +725,7 @@ test-suite chainweb-tests , pact-tng:pact-request-api , pact-tng:test-utils , patience >= 0.3 + , prettyprinter , property-matchers ^>= 0.2 , pretty-show , quickcheck-instances >= 0.3 diff --git a/test/unit/Chainweb/Test/Pact5/RemotePactTest.hs b/test/unit/Chainweb/Test/Pact5/RemotePactTest.hs index b6aa54cae..8bfe0db0b 100644 --- a/test/unit/Chainweb/Test/Pact5/RemotePactTest.hs +++ b/test/unit/Chainweb/Test/Pact5/RemotePactTest.hs @@ -23,12 +23,13 @@ {-# options_ghc -Wwarn -fno-warn-name-shadowing -fno-warn-unused-top-binds #-} {-# LANGUAGE PartialTypeSignatures #-} {-# OPTIONS_GHC -Wno-partial-type-signatures #-} +{-# LANGUAGE ViewPatterns #-} module Chainweb.Test.Pact5.RemotePactTest ( tests ) where -import Control.Concurrent.Async +import Control.Concurrent.Async hiding (poll) import Control.Exception (evaluate) import Control.Exception.Safe import Control.Lens @@ -40,17 +41,13 @@ import Data.Aeson qualified as Aeson import Data.Aeson.Lens qualified as A import Data.ByteString.Base64.URL qualified as B64U import Data.ByteString.Lazy qualified as BL -import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HashMap import Data.HashSet qualified as HashSet import Data.List qualified as List -import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NE import Data.Maybe (fromMaybe) -import Data.String (fromString) import Data.Text (Text) import Data.Text qualified as T -import Data.Text.Encoding qualified as T import GHC.Stack import Network.Connection qualified as HTTP import Network.HTTP.Client (Manager) @@ -60,12 +57,13 @@ import Network.TLS qualified as TLS import Network.Wai.Handler.Warp qualified as W import Network.Wai.Handler.WarpTLS qualified as W import Network.X509.SelfSigned +import Prettyprinter qualified as PP import PropertyMatchers ((?)) import PropertyMatchers qualified as P import Servant.Client import System.IO.Unsafe (unsafePerformIO) import Test.Tasty -import Test.Tasty.HUnit (assertEqual, testCaseSteps) +import Test.Tasty.HUnit (testCaseSteps) import Pact.Core.Capabilities import Pact.Core.Command.RPC (ContMsg (..)) @@ -85,7 +83,7 @@ import Pact.Types.Hash qualified as Pact4 import Chainweb.BlockHeader (blockHeight) import Chainweb.ChainId import Chainweb.CutDB.RestAPI.Server (someCutGetServer) -import Chainweb.Graph (petersonChainGraph, singletonChainGraph) +import Chainweb.Graph (petersonChainGraph, singletonChainGraph, twentyChainGraph) import Chainweb.Mempool.Mempool (TransactionHash (..)) import Chainweb.Pact.RestAPI.Client import Chainweb.Pact.RestAPI.Server @@ -101,6 +99,11 @@ import Chainweb.Test.Utils (TestPact5CommandResult, deadbeef, withResource') import Chainweb.Utils import Chainweb.Version import Chainweb.WebPactExecutionService +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL +import Network.HTTP.Types.Status (notFound404) +import Data.Tuple (Solo(..)) +import Data.Foldable (traverse_, toList) data Fixture = Fixture { _cutFixture :: CutFixture.Fixture @@ -174,8 +177,8 @@ pollingInvalidRequestKeyTest baseRdb _step = runResourceT $ do let clientEnv = fixture ^. serviceClientEnv liftIO $ do - pollResult <- polling v cid clientEnv (NE.singleton pactDeadBeef) - assertEqual "invalid poll should return no results" pollResult HashMap.empty + poll v cid clientEnv (MkSolo pactDeadBeef) >>= + P.propful ? MkSolo ? P.equals Nothing pollingConfirmationDepthTest :: RocksDb -> Step -> IO () pollingConfirmationDepthTest baseRdb _step = runResourceT $ do @@ -199,55 +202,55 @@ pollingConfirmationDepthTest baseRdb _step = runResourceT $ do liftIO $ do cmd1 <- buildTextCmd v (trivialTx cid 42) cmd2 <- buildTextCmd v (trivialTx cid 43) - let rks = cmdToRequestKey cmd1 NE.:| [cmdToRequestKey cmd2] + let rks = [cmdToRequestKey cmd1, cmdToRequestKey cmd2] - let expectSuccessful :: (HasCallStack, _) => P.Prop (HashMap RequestKey (CommandResult _ _)) - expectSuccessful = P.propful ? HashMap.fromList - [ (cmdToRequestKey cmd1, P.fun _crResult ? P.equals (PactResultOk (PInteger 42))) - , (cmdToRequestKey cmd2, P.fun _crResult ? P.equals (PactResultOk (PInteger 43))) + let expectSuccessful :: (HasCallStack, _) => P.Prop [Maybe TestPact5CommandResult] + expectSuccessful = P.propful + [ P.match _Just ? P.fun _crResult ? P.equals (PactResultOk (PInteger 42)) + , P.match _Just ? P.fun _crResult ? P.equals (PactResultOk (PInteger 43)) ] + let expectEmpty :: (HasCallStack, _) => _ - expectEmpty = P.equals HashMap.empty + expectEmpty = traverse_ (P.equals Nothing) - sending v cid clientEnv (cmd1 NE.:| [cmd2]) - >>= P.equals rks + send v cid clientEnv (cmd1, cmd2) - pollingWithDepth v cid clientEnv rks Nothing + pollWithDepth v cid clientEnv rks Nothing >>= expectEmpty - pollingWithDepth v cid clientEnv rks (Just (ConfirmationDepth 0)) + pollWithDepth v cid clientEnv rks (Just (ConfirmationDepth 0)) >>= expectEmpty CutFixture.advanceAllChains_ (fixture ^. cutFixture) - pollingWithDepth v cid clientEnv rks Nothing + pollWithDepth v cid clientEnv rks Nothing >>= expectSuccessful - pollingWithDepth v cid clientEnv rks (Just (ConfirmationDepth 0)) + pollWithDepth v cid clientEnv rks (Just (ConfirmationDepth 0)) >>= expectSuccessful - pollingWithDepth v cid clientEnv rks (Just (ConfirmationDepth 1)) + pollWithDepth v cid clientEnv rks (Just (ConfirmationDepth 1)) >>= expectEmpty CutFixture.advanceAllChains_ (fixture ^. cutFixture) - pollingWithDepth v cid clientEnv rks Nothing + pollWithDepth v cid clientEnv rks Nothing >>= expectSuccessful - pollingWithDepth v cid clientEnv rks (Just (ConfirmationDepth 0)) + pollWithDepth v cid clientEnv rks (Just (ConfirmationDepth 0)) >>= expectSuccessful - pollingWithDepth v cid clientEnv rks (Just (ConfirmationDepth 1)) + pollWithDepth v cid clientEnv rks (Just (ConfirmationDepth 1)) >>= expectSuccessful - pollingWithDepth v cid clientEnv rks (Just (ConfirmationDepth 2)) + pollWithDepth v cid clientEnv rks (Just (ConfirmationDepth 2)) >>= expectEmpty CutFixture.advanceAllChains_ (fixture ^. cutFixture) - pollingWithDepth v cid clientEnv rks Nothing + pollWithDepth v cid clientEnv rks Nothing >>= expectSuccessful - pollingWithDepth v cid clientEnv rks (Just (ConfirmationDepth 0)) + pollWithDepth v cid clientEnv rks (Just (ConfirmationDepth 0)) >>= expectSuccessful - pollingWithDepth v cid clientEnv rks (Just (ConfirmationDepth 1)) + pollWithDepth v cid clientEnv rks (Just (ConfirmationDepth 1)) >>= expectSuccessful - pollingWithDepth v cid clientEnv rks (Just (ConfirmationDepth 2)) + pollWithDepth v cid clientEnv rks (Just (ConfirmationDepth 2)) >>= expectSuccessful - pollingWithDepth v cid clientEnv rks (Just (ConfirmationDepth 3)) + pollWithDepth v cid clientEnv rks (Just (ConfirmationDepth 3)) >>= expectEmpty return () @@ -262,7 +265,7 @@ spvTest baseRdb step = runResourceT $ do let targetChain = unsafeChainId 9 liftIO $ do - send <- buildTextCmd v + initiator <- buildTextCmd v $ set cbSigners [ mkEd25519Signer' sender00 [ CapToken (QualifiedName "GAS" (ModuleName "coin" Nothing)) [] @@ -281,15 +284,15 @@ spvTest baseRdb step = runResourceT $ do $ set cbGasLimit (GasLimit (Gas 1_000)) $ defaultCmd - step "xchain send" - sendReqKey <- fmap NE.head $ sending v srcChain clientEnv (NE.singleton send) + step "xchain initiate" + send v srcChain clientEnv (NE.singleton initiator) + let initiatorReqKey = cmdToRequestKey initiator (sendCut, _) <- CutFixture.advanceAllChains (fixture ^. cutFixture) - sendCr <- fmap (HashMap.! sendReqKey) $ pollingWithDepth v srcChain clientEnv (NE.singleton sendReqKey) (Just (ConfirmationDepth 0)) + MkSolo (Just sendCr) <- pollWithDepth v srcChain clientEnv (MkSolo initiatorReqKey) (Just (ConfirmationDepth 0)) let cont = fromMaybe (error "missing continuation") (_crContinuation sendCr) step "waiting" - _ <- replicateM_ 10 $ do - CutFixture.advanceAllChains (fixture ^. cutFixture) + replicateM_ 10 $ CutFixture.advanceAllChains_ (fixture ^. cutFixture) let sendHeight = sendCut ^?! ixg srcChain . blockHeight spvProof <- createTransactionOutputProof_ (fixture ^. cutFixture . CutFixture.fixtureWebBlockHeaderDb) (fixture ^. cutFixture . CutFixture.fixturePayloadDb) targetChain srcChain sendHeight 0 let contMsg = ContMsg @@ -312,9 +315,10 @@ spvTest baseRdb step = runResourceT $ do $ set cbGasPrice (GasPrice 0.01) $ set cbGasLimit (GasLimit (Gas 1_000)) $ defaultCmd - recvReqKey <- fmap NE.head $ sending v targetChain clientEnv (NE.singleton recv) - _ <- CutFixture.advanceAllChains (fixture ^. cutFixture) - recvCr <- fmap (HashMap.! recvReqKey) $ polling v targetChain clientEnv (NE.singleton recvReqKey) + send v targetChain clientEnv [recv] + let recvReqKey = cmdToRequestKey recv + CutFixture.advanceAllChains_ (fixture ^. cutFixture) + MkSolo (Just recvCr) <- poll v targetChain clientEnv (MkSolo recvReqKey) recvCr & P.allTrue [ P.fun _crResult ? P.match _PactResultOk P.succeed @@ -342,61 +346,71 @@ fails p actual = try actual >>= \case invalidTxsTest :: RocksDb -> Step -> IO () invalidTxsTest rdb _step = runResourceT $ do let v = pact5InstantCpmTestVersion petersonChainGraph + let wrongV = pact5InstantCpmTestVersion twentyChainGraph fixture <- mkFixture v rdb let clientEnv = fixture ^. serviceClientEnv let cid = unsafeChainId 0 + let wrongChain = unsafeChainId 4 - let assertExnContains expectedErrStr (SendingException actualErrStr) - | expectedErrStr `List.isInfixOf` actualErrStr = P.succeed actualErrStr + let textContains :: HasCallStack => _ + textContains expectedStr actualStr + | expectedStr `T.isInfixOf` actualStr = P.succeed actualStr | otherwise = - P.fail ("Error containing: " <> fromString expectedErrStr) actualErrStr + P.fail ("String containing: " <> PP.pretty expectedStr) actualStr let validationFailedPrefix cmd = "Validation failed for hash " <> sshow (_cmdHash cmd) <> ": " liftIO $ do - cmdParseFailure <- buildTextCmd v - $ set cbChainId cid - $ set cbRPC (mkExec "(+ 1" PUnit) - $ defaultCmd - sending v cid clientEnv (NE.singleton cmdParseFailure) - & fails ? assertExnContains "Pact parse error" - - cmdInvalidPayloadHash <- do - bareCmd <- buildTextCmd v - $ set cbChainId cid - $ set cbRPC (mkExec "(+ 1 2)" (mkKeySetData "sender00" [sender00])) - $ defaultCmd - pure $ bareCmd - { _cmdHash = Pact5.hash "fakehash" - } - sending v cid clientEnv (NE.singleton cmdInvalidPayloadHash) - & fails ? assertExnContains (validationFailedPrefix cmdInvalidPayloadHash <> "Invalid transaction hash") - - cmdSignersSigsLengthMismatch1 <- do - bareCmd <- buildTextCmd v - $ set cbSigners [mkEd25519Signer' sender00 []] + do + cmdParseFailure <- buildTextCmd v $ set cbChainId cid - $ set cbRPC (mkExec "(+ 1 2)" (mkKeySetData "sender00" [sender00])) + $ set cbRPC (mkExec "(+ 1" PUnit) $ defaultCmd - pure $ bareCmd - { _cmdSigs = [] - } - sending v cid clientEnv (NE.singleton cmdSignersSigsLengthMismatch1) - & fails ? assertExnContains (validationFailedPrefix cmdSignersSigsLengthMismatch1 <> "Invalid transaction sigs") - - cmdSignersSigsLengthMismatch2 <- liftIO $ do - bareCmd <- buildTextCmd v - $ set cbSigners [] - $ set cbChainId cid - $ set cbRPC (mkExec "(+ 1 2)" (mkKeySetData "sender00" [sender00])) - $ defaultCmd - pure $ bareCmd - { -- This is an invalid ED25519 signature, but length signers == length signatures is checked first - _cmdSigs = [ED25519Sig "fakeSig"] - } - sending v cid clientEnv (NE.singleton cmdSignersSigsLengthMismatch2) - & fails ? assertExnContains (validationFailedPrefix cmdSignersSigsLengthMismatch2 <> "Invalid transaction sigs") + send v cid clientEnv [cmdParseFailure] + & fails ? P.match _FailureResponse ? P.fun responseBody ? textContains "Pact parse error" + + do + cmdInvalidPayloadHash <- do + bareCmd <- buildTextCmd v + $ set cbChainId cid + $ set cbRPC (mkExec "(+ 1 2)" (mkKeySetData "sender00" [sender00])) + $ defaultCmd + pure $ bareCmd + { _cmdHash = Pact5.hash "fakehash" + } + send v cid clientEnv [cmdInvalidPayloadHash] + & fails ? P.match _FailureResponse ? P.fun responseBody ? textContains + (validationFailedPrefix cmdInvalidPayloadHash <> "Invalid transaction hash") + + do + cmdSignersSigsLengthMismatch1 <- do + bareCmd <- buildTextCmd v + $ set cbSigners [mkEd25519Signer' sender00 []] + $ set cbChainId cid + $ set cbRPC (mkExec "(+ 1 2)" (mkKeySetData "sender00" [sender00])) + $ defaultCmd + pure $ bareCmd + { _cmdSigs = [] + } + send v cid clientEnv [cmdSignersSigsLengthMismatch1] + & fails ? P.match _FailureResponse ? P.fun responseBody ? textContains + (validationFailedPrefix cmdSignersSigsLengthMismatch1 <> "Invalid transaction sigs") + + do + cmdSignersSigsLengthMismatch2 <- liftIO $ do + bareCmd <- buildTextCmd v + $ set cbSigners [] + $ set cbChainId cid + $ set cbRPC (mkExec "(+ 1 2)" (mkKeySetData "sender00" [sender00])) + $ defaultCmd + pure $ bareCmd + { -- This is an invalid ED25519 signature, but length signers == length signatures is checked first + _cmdSigs = [ED25519Sig "fakeSig"] + } + send v cid clientEnv (NE.singleton cmdSignersSigsLengthMismatch2) + & fails ? P.match _FailureResponse ? P.fun responseBody ? textContains + (validationFailedPrefix cmdSignersSigsLengthMismatch2 <> "Invalid transaction sigs") cmdInvalidUserSig <- liftIO $ do bareCmd <- buildTextCmd v @@ -408,28 +422,50 @@ invalidTxsTest rdb _step = runResourceT $ do { _cmdSigs = [ED25519Sig "fakeSig"] } - sending v cid clientEnv (NE.singleton cmdInvalidUserSig) - & fails ? assertExnContains (validationFailedPrefix cmdInvalidUserSig <> "Invalid transaction sigs") - cmdGood <- buildTextCmd v $ set cbSigners [mkEd25519Signer' sender00 []] $ set cbChainId cid $ set cbRPC (mkExec "(+ 1 2)" (mkKeySetData "sender00" [sender00])) $ defaultCmd - -- Test that [badCmd, goodCmd] fails on badCmd, and the batch is rejected. - -- We just re-use a previously built bad cmd. - sending v cid clientEnv (NE.fromList [cmdInvalidUserSig, cmdGood]) - & fails ? assertExnContains (validationFailedPrefix cmdInvalidUserSig <> "Invalid transaction sigs") - -- Test that [goodCmd, badCmd] fails on badCmd, and the batch is rejected. - -- Order matters, and the error message also indicates the position of the - -- failing tx. - -- We just re-use a previously built bad cmd. - sending v cid clientEnv (NE.fromList [cmdGood, cmdInvalidUserSig]) - & fails ? assertExnContains (validationFailedPrefix cmdInvalidUserSig <> "Invalid transaction sigs") - - sending v (unsafeChainId 4) clientEnv (NE.fromList [cmdGood]) - & fails ? assertExnContains - (validationFailedPrefix cmdGood <> "Transaction metadata (chain id, chainweb version) conflicts with this endpoint") + + do + send v cid clientEnv (NE.singleton cmdInvalidUserSig) + & fails ? P.match _FailureResponse ? P.fun responseBody ? textContains + (validationFailedPrefix cmdInvalidUserSig <> "Invalid transaction sigs") + -- Test that [badCmd, goodCmd] fails on badCmd, and the batch is rejected. + -- We just re-use a previously built bad cmd. + send v cid clientEnv (NE.fromList [cmdInvalidUserSig, cmdGood]) + & fails ? P.match _FailureResponse ? P.fun responseBody ? textContains + (validationFailedPrefix cmdInvalidUserSig <> "Invalid transaction sigs") + -- Test that [goodCmd, badCmd] fails on badCmd, and the batch is rejected. + -- Order matters, and the error message also indicates the position of the + -- failing tx. + -- We just re-use a previously built bad cmd. + send v cid clientEnv (NE.fromList [cmdGood, cmdInvalidUserSig]) + & fails ? P.match _FailureResponse ? P.fun responseBody ? textContains + (validationFailedPrefix cmdInvalidUserSig <> "Invalid transaction sigs") + + do + send v wrongChain clientEnv (NE.fromList [cmdGood]) + & fails ? P.match _FailureResponse ? P.fun responseBody ? textContains + (validationFailedPrefix cmdGood <> "Transaction metadata (chain id, chainweb version) conflicts with this endpoint") + + send wrongV cid clientEnv (NE.fromList [cmdGood]) + & fails ? P.match _FailureResponse ? P.allTrue + [ P.fun responseStatusCode ? P.equals notFound404 + , P.fun responseBody ? P.equals "" + ] + + cmdWrongV <- buildTextCmd wrongV + $ set cbSigners [mkEd25519Signer' sender00 []] + $ set cbChainId cid + $ set cbRPC (mkExec "(+ 1 2)" (mkKeySetData "sender00" [sender00])) + $ defaultCmd + + send v cid clientEnv (NE.fromList [cmdWrongV]) + & fails ? P.match _FailureResponse ? P.fun responseBody ? textContains + (validationFailedPrefix cmdWrongV <> "Transaction metadata (chain id, chainweb version) conflicts with this endpoint") + caplistTest :: RocksDb -> Step -> IO () caplistTest baseRdb step = runResourceT $ do @@ -456,8 +492,9 @@ caplistTest baseRdb step = runResourceT $ do $ defaultCmd step "sending" + send v cid clientEnv (NE.fromList [tx0]) - recvReqKey <- fmap NE.head $ sending v cid clientEnv (NE.fromList [tx0]) + let recvReqKey = cmdToRequestKey tx0 step "advancing chains" @@ -465,8 +502,8 @@ caplistTest baseRdb step = runResourceT $ do step "polling" - polling v cid clientEnv (NE.fromList [recvReqKey]) >>= - P.propful ? HashMap.singleton recvReqKey ? + poll v cid clientEnv (MkSolo recvReqKey) >>= + P.propful ? MkSolo ? P.match _Just ? P.allTrue [ P.fun _crResult ? P.match (_PactResultOk . _PString) ? P.equals "Write succeeded" , P.fun _crMetaData ? P.match (_Just . A._Object . at "blockHash") ? P.match _Just P.succeed @@ -493,10 +530,10 @@ spvTest t cenv step = do r <- flip runClientM cenv $ do void $ liftIO $ step "sendApiClient: submit batch" - rks <- liftIO $ sending v sid cenv batch + rks <- liftIO $ send v sid cenv batch void $ liftIO $ step "pollApiClient: poll until key is found" - void $ liftIO $ polling v sid cenv rks ExpectPactResult + void $ liftIO $ poll v sid cenv rks ExpectPactResult void $ liftIO $ step "spvApiClient: submit request key" liftIO $ spv v sid cenv (SpvRequest (NEL.head $ _rkRequestKeys rks) tid) @@ -530,54 +567,64 @@ spvTest t cenv step = do ] -} -newtype PollingException = PollingException String +newtype PollException = PollException String deriving stock (Show) deriving anyclass (Exception) -polling :: () +poll :: (Traversable t) => ChainwebVersion -> ChainId -> ClientEnv - -> NonEmpty RequestKey - -> IO (HashMap RequestKey TestPact5CommandResult) -polling v cid clientEnv rks = do - pollingWithDepth v cid clientEnv rks Nothing + -> t RequestKey + -> IO (t (Maybe TestPact5CommandResult)) +poll v cid clientEnv rks = do + pollWithDepth v cid clientEnv rks Nothing -pollingWithDepth :: () +pollWithDepth :: (Traversable t) => ChainwebVersion -> ChainId -> ClientEnv - -> NonEmpty RequestKey + -> t RequestKey -> Maybe ConfirmationDepth - -> IO (HashMap RequestKey TestPact5CommandResult) -pollingWithDepth v cid clientEnv rks mConfirmationDepth = do - poll <- runClientM (pactPollWithQueryApiClient v cid mConfirmationDepth (Pact5.PollRequest rks)) clientEnv + -> IO (t (Maybe TestPact5CommandResult)) +pollWithDepth v cid clientEnv rks mConfirmationDepth = do + let rksNel = NE.fromList (toList rks) + poll <- runClientM (pactPollWithQueryApiClient v cid mConfirmationDepth (Pact5.PollRequest rksNel)) clientEnv case poll of Left e -> do - throwM (PollingException (show e)) + throwM (PollException (show e)) Right (Pact5.PollResponse response) -> do - return response + -- the poll should only return results for commands + -- that were polled for + response & P.fun HashMap.keys ? traverse_ ? P.fun (\rk -> elem rk rks) ? P.bool + return + (rks <&> (\rk -> HashMap.lookup rk response)) -newtype SendingException = SendingException String +newtype SendException = SendException ClientError deriving stock (Show) deriving anyclass (Exception) +_FailureResponse :: Fold SendException (ResponseF Text) +_FailureResponse = folding $ \case + SendException (FailureResponse _req resp) -> Just (TL.toStrict . TL.decodeUtf8 <$> resp) + _ -> Nothing -sending :: () +send :: (Each cmds cmds (Command Text) (Command Text)) => ChainwebVersion -> ChainId -> ClientEnv - -> NonEmpty (Command Text) - -> IO (NonEmpty RequestKey) -sending v cid clientEnv cmds = do - let batch = Pact4.SubmitBatch (NE.map toPact4Command cmds) + -> cmds + -> IO () +send v cid clientEnv cmds = do + let commands = NE.fromList $ toListOf each cmds + let batch = Pact4.SubmitBatch (fmap toPact4Command commands) send <- runClientM (pactSendApiClient v cid batch) clientEnv case send of - Left (FailureResponse _req resp) -> do - throwM (SendingException (T.unpack $ T.decodeUtf8 $ BL.toStrict (responseBody resp))) - Left e -> - throwM (SendingException (show e)) - Right (Pact4.RequestKeys response) -> do - return (NE.map toPact5RequestKey response) + Left e -> do + throwM (SendException e) + Right (Pact4.RequestKeys (fmap toPact5RequestKey -> response)) -> do + -- the returned request keys should always be exactly the hashes + -- of the commands + response & P.equals (cmdToRequestKey <$> commands) toPact5RequestKey :: Pact4.RequestKey -> RequestKey toPact5RequestKey = \case