Add caplist test

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