diff --git a/test/unit/Chainweb/Test/Pact5/RemotePactTest.hs b/test/unit/Chainweb/Test/Pact5/RemotePactTest.hs index b8b884a35..9a7c4d096 100644 --- a/test/unit/Chainweb/Test/Pact5/RemotePactTest.hs +++ b/test/unit/Chainweb/Test/Pact5/RemotePactTest.hs @@ -30,6 +30,7 @@ import Pact.Core.SPV import Data.ByteString.Base64.URL qualified as B64U import Data.ByteString.Lazy qualified as BL import Data.Aeson qualified as A +import Data.Aeson.Lens qualified as A import Pact.Core.Command.RPC (ContMsg(..)) import Control.Monad (replicateM_) import Chainweb.SPV.CreateProof (createTransactionOutputProof_) @@ -64,10 +65,8 @@ import Chainweb.Test.Utils (deadbeef, TestPact5CommandResult) import Chainweb.Utils import Chainweb.Version import Chainweb.WebPactExecutionService -import Control.Concurrent -import Control.Exception (Exception, AsyncException(..)) +import Control.Exception.Safe import Control.Lens -import Control.Monad.Catch (throwM) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Resource (ResourceT, runResourceT, allocate) import Data.Aeson qualified as Aeson @@ -87,8 +86,10 @@ import PropertyMatchers ((?)) import PropertyMatchers qualified as P import Servant.Client import Test.Tasty -import Test.Tasty.HUnit (assertEqual, testCase) +import Test.Tasty.HUnit (assertEqual, testCase, testCaseSteps) import qualified Pact.Types.Command as Pact4 +import Data.String (fromString) +import Control.Concurrent.Async data Fixture = Fixture { _cutFixture :: CutFixture.Fixture @@ -116,10 +117,10 @@ mkFixture v baseRdb = do -- Run pact server API (port, socket) <- snd <$> allocate W.openFreePort (Network.close . snd) _ <- allocate - (forkIO $ do + (async $ do W.runTLSSocket (tlsServerSettings cert key) W.defaultSettings socket app ) - (\tid -> throwTo tid ThreadKilled) + cancel serviceClientEnv <- liftIO $ do let defaultTLSSettings = (HTTP.TLSSettingsSimple True False False TLS.defaultSupported) @@ -141,6 +142,8 @@ tests rdb = testGroup "Pact5 RemotePactTest" [ testCase "pollingInvalidRequestKeyTest" (pollingInvalidRequestKeyTest rdb) , testCase "pollingConfirmationDepthTest" (pollingConfirmationDepthTest rdb) , testCase "spvTest" (spvTest rdb) + , testCase "invalidTxsTest" (invalidTxsTest rdb) + , testCaseSteps "caplistTest" (caplistTest rdb) ] pollingInvalidRequestKeyTest :: RocksDb -> IO () @@ -285,6 +288,145 @@ spvTest baseRdb = runResourceT $ do pure () +fails :: Exception e => P.Prop e -> P.Prop (IO a) +fails p actual = try actual >>= \case + Left e -> p e + _ -> P.fail "a failed computation" actual + +invalidTxsTest :: RocksDb -> IO () +invalidTxsTest baseRdb = runResourceT $ do + let v = pact5InstantCpmTestVersion petersonChainGraph + fixture <- mkFixture v baseRdb + let clientEnv = fixture ^. serviceClientEnv + + let cid = unsafeChainId 0 + + let assertExnContains expectedErrStr (SendingException actualErrStr) + | expectedErrStr `List.isInfixOf` actualErrStr = P.succeed actualErrStr + | otherwise = + P.fail ("Error containing: " <> fromString expectedErrStr) actualErrStr + + 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 []] + $ set cbChainId cid + $ set cbRPC (mkExec "(+ 1 2)" (mkKeySetData "sender00" [sender00])) + $ 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") + + cmdInvalidUserSig <- liftIO $ do + bareCmd <- buildTextCmd v + $ set cbSigners [mkEd25519Signer' sender00 []] + $ set cbChainId cid + $ set cbRPC (mkExec "(+ 1 2)" (mkKeySetData "sender00" [sender00])) + $ defaultCmd + pure $ bareCmd + { _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") + +caplistTest :: RocksDb -> (String -> IO ()) -> IO () +caplistTest baseRdb step = runResourceT $ do + let testCaseStep m = liftIO (step m) + + testCaseStep "setting up" + let v = pact5InstantCpmTestVersion petersonChainGraph + fixture <- mkFixture v baseRdb + let clientEnv = fixture ^. serviceClientEnv + + let cid = unsafeChainId 0 + + liftIO $ do + + tx0 <- buildTextCmd v + $ set cbSigners + [ mkEd25519Signer' sender00 + [ CapToken (QualifiedName "GAS" (ModuleName "coin" Nothing)) [] + , CapToken (QualifiedName "TRANSFER" (ModuleName "coin" Nothing)) + [ PString "sender00" + , PString "sender01" + , PDecimal 100.0 + ] + ] + ] + $ set cbChainId cid + $ set cbRPC (mkExec "(coin.transfer \"sender00\" \"sender01\" 100.0)" PUnit) + $ defaultCmd + + testCaseStep "sending" + + recvReqKey <- fmap NE.head $ sending v cid clientEnv (NE.fromList [tx0]) + + testCaseStep "advancing chains" + + CutFixture.advanceAllChains_ (fixture ^. cutFixture) + + testCaseStep "polling" + + polling v cid clientEnv (NE.fromList [recvReqKey]) >>= + P.propful ? HashMap.singleton recvReqKey ? + 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 + ] + + {- recvPwos <- runCutWithTx v pacts targetMempoolRef blockDb $ \_n _bHeight _bHash bHeader -> do buildCwCmd "transfer-crosschain" v @@ -296,6 +438,7 @@ spvTest baseRdb = runResourceT $ do $ set cbTTL 100 $ defaultCmd -} + {- spvTest :: Pact.TxCreationTime -> ClientEnv -> (String -> IO ()) -> IO () spvTest t cenv step = do