From 6abfb2d472ce2f130b7796639edc3c17b7ed9678 Mon Sep 17 00:00:00 2001 From: Edmund Noble Date: Tue, 17 Dec 2024 13:58:18 -0500 Subject: [PATCH] Add caplist test --- .../Chainweb/Test/Pact5/RemotePactTest.hs | 148 ++++++++++++------ 1 file changed, 97 insertions(+), 51 deletions(-) diff --git a/test/unit/Chainweb/Test/Pact5/RemotePactTest.hs b/test/unit/Chainweb/Test/Pact5/RemotePactTest.hs index 5737cbbb9..4c7a70eb1 100644 --- a/test/unit/Chainweb/Test/Pact5/RemotePactTest.hs +++ b/test/unit/Chainweb/Test/Pact5/RemotePactTest.hs @@ -25,76 +25,75 @@ module Chainweb.Test.Pact5.RemotePactTest ( tests ) where -import Pact.Core.DefPacts.Types -import Pact.Core.SPV +import Control.Concurrent.Async +import Control.Exception.Safe +import Control.Lens +import Control.Monad (replicateM_) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Resource (ResourceT, allocate, runResourceT) +import Data.Aeson qualified as A +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.Aeson qualified as A -import Pact.Core.Command.RPC (ContMsg(..)) -import Control.Monad (replicateM_) -import Chainweb.SPV.CreateProof (createTransactionOutputProof_) -import Chainweb.BlockHeader (blockHeight) +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 Pact.Core.Names -import Pact.Core.Capabilities -import Pact.Core.PactValue -import Pact.Core.Command.Server qualified as Pact5 -import Chainweb.CutDB.RestAPI.Server (someCutGetServer) +import Data.String (fromString) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as T import Network.Connection qualified as HTTP import Network.HTTP.Client.TLS qualified as HTTP import Network.Socket qualified as Network import Network.TLS qualified as TLS import Network.Wai.Handler.Warp qualified as W import Network.Wai.Handler.WarpTLS qualified as W -import Chainweb.RestAPI.Utils (someServerApplication) -import "pact" Pact.Types.API qualified as Pact4 -import "pact" Pact.Types.Hash qualified as Pact4 +import Network.X509.SelfSigned +import PropertyMatchers ((?)) +import PropertyMatchers qualified as P +import Servant.Client +import Test.Tasty +import Test.Tasty.HUnit (assertEqual, testCase, testCaseSteps) + +import Pact.Core.Capabilities +import Pact.Core.Command.RPC (ContMsg (..)) +import Pact.Core.Command.Server qualified as Pact5 +import Pact.Core.Command.Types +import Pact.Core.DefPacts.Types +import Pact.Core.Gas.Types +import Pact.Core.Hash qualified as Pact5 +import Pact.Core.Names +import Pact.Core.PactValue +import Pact.Core.SPV +import Pact.JSON.Encode qualified as J +import Pact.Types.Command qualified as Pact4 +import Pact.Types.API qualified as Pact4 +import Pact.Types.Hash qualified as Pact4 + +import Chainweb.BlockHeader (blockHeight) import Chainweb.ChainId -import Chainweb.Graph (singletonChainGraph, petersonChainGraph) -import Chainweb.Mempool.Mempool (TransactionHash(..)) +import Chainweb.CutDB.RestAPI.Server (someCutGetServer) +import Chainweb.Graph (petersonChainGraph, singletonChainGraph) +import Chainweb.Mempool.Mempool (TransactionHash (..)) import Chainweb.Pact.RestAPI.Client import Chainweb.Pact.RestAPI.Server import Chainweb.Pact.Types +import Chainweb.RestAPI.Utils (someServerApplication) +import Chainweb.SPV.CreateProof (createTransactionOutputProof_) import Chainweb.Storage.Table.RocksDB import Chainweb.Test.Pact5.CmdBuilder import Chainweb.Test.Pact5.CutFixture qualified as CutFixture import Chainweb.Test.Pact5.Utils import Chainweb.Test.TestVersions -import Chainweb.Test.Utils (deadbeef, TestPact5CommandResult) +import Chainweb.Test.Utils (TestPact5CommandResult, deadbeef) import Chainweb.Utils import Chainweb.Version import Chainweb.WebPactExecutionService -import Control.Concurrent -import Control.Exception (Exception, AsyncException(..), try) -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 -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.Text (Text) -import Network.X509.SelfSigned -import Pact.Core.Command.Types -import Pact.Core.Gas.Types -import Pact.Core.Hash qualified as Pact5 -import Pact.JSON.Encode qualified as J -import PropertyMatchers ((?)) -import PropertyMatchers qualified as P -import Servant.Client -import Test.Tasty -import Test.Tasty.HUnit (assertEqual, testCase) -import qualified Pact.Types.Command as Pact4 -import qualified Pact.Core.Command.Types as Pact5 -import qualified Data.HashMap.Strict as HM -import GHC.Stack (HasCallStack) -import Data.String (fromString) -import qualified Data.Text.Encoding as T -import qualified Data.Text as T data Fixture = Fixture { _cutFixture :: CutFixture.Fixture @@ -122,10 +121,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) @@ -148,6 +147,7 @@ tests rdb = testGroup "Pact5 RemotePactTest" , testCase "pollingConfirmationDepthTest" (pollingConfirmationDepthTest rdb) , testCase "spvTest" (spvTest rdb) , testCase "invalidTxsTest" (invalidTxsTest rdb) + , testCaseSteps "caplistTest" (caplistTest rdb) ] pollingInvalidRequestKeyTest :: RocksDb -> IO () @@ -385,6 +385,51 @@ invalidTxsTest baseRdb = runResourceT $ do 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 @@ -397,6 +442,7 @@ invalidTxsTest baseRdb = runResourceT $ do $ set cbTTL 100 $ defaultCmd -} + {- spvTest :: Pact.TxCreationTime -> ClientEnv -> (String -> IO ()) -> IO () spvTest t cenv step = do