Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Add caplist test #2081

Merged
merged 2 commits into from
Dec 18, 2024
+109 −64
Merged

Add caplist test #2081

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
327c726
Remove the version argument from advanceAllChains
edmundnoble Dec 17, 2024
6cad2cc
Add caplist test
edmundnoble Dec 17, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
13 changes: 6 additions & 7 deletions test/unit/Chainweb/Test/Pact5/CutFixture.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -115,18 +115,18 @@ mkFixture v pactServiceConfig baseRdb = do
, _fixtureMempools = OnChains $ fst <$> perChain
, _fixturePactQueues = OnChains $ snd <$> perChain
}
_ <- liftIO $ advanceAllChains v fixture
_ <- liftIO $ advanceAllChains fixture
return fixture

-- | Advance all chains by one block, filling that block with whatever is in
-- their mempools at the time.
--
advanceAllChains
:: HasCallStack
=> ChainwebVersion
-> Fixture
=> Fixture
-> IO (Cut, ChainMap (Vector (CommandResult Pact5.Hash Text)))
advanceAllChains v Fixture{..} = do
advanceAllChains Fixture{..} = do
let v = _chainwebVersion _fixtureCutDb
latestCut <- liftIO $ _fixtureCutDb ^. cut
let blockHeights = fmap (view blockHeight) $ latestCut ^. cutMap
let latestBlockHeight = maximum blockHeights
Expand All @@ -149,10 +149,9 @@ advanceAllChains v Fixture{..} = do

advanceAllChains_
:: HasCallStack
=> ChainwebVersion
-> Fixture
=> Fixture
-> IO ()
advanceAllChains_ v f = void $ advanceAllChains v f
advanceAllChains_ f = void $ advanceAllChains f

withTestCutDb :: (Logger logger)
=> logger
Expand Down
160 changes: 103 additions & 57 deletions test/unit/Chainweb/Test/Pact5/RemotePactTest.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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 $
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)
Expand All @@ -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 ()
Expand Down Expand Up @@ -178,7 +178,7 @@ pollingConfirmationDepthTest baseRdb = runResourceT $ do
pollingWithDepth v cid clientEnv rks (Just (ConfirmationDepth 0)) >>= \response -> do
assertEqual "there are no command results at depth 0" response HashMap.empty

CutFixture.advanceAllChains_ v (fixture ^. cutFixture)
CutFixture.advanceAllChains_ (fixture ^. cutFixture)

pollingWithDepth v cid clientEnv rks Nothing >>= \response -> do
assertEqual "results are visible at depth 0" 2 (HashMap.size response)
Expand All @@ -187,7 +187,7 @@ pollingConfirmationDepthTest baseRdb = runResourceT $ do
pollingWithDepth v cid clientEnv rks (Just (ConfirmationDepth 1)) >>= \response -> do
assertEqual "results are not visible at depth 1" 0 (HashMap.size response)

CutFixture.advanceAllChains_ v (fixture ^. cutFixture)
CutFixture.advanceAllChains_ (fixture ^. cutFixture)

pollingWithDepth v cid clientEnv rks Nothing >>= \response -> do
assertEqual "results are visible at depth 0" 2 (HashMap.size response)
Expand All @@ -198,7 +198,7 @@ pollingConfirmationDepthTest baseRdb = runResourceT $ do
pollingWithDepth v cid clientEnv rks (Just (ConfirmationDepth 2)) >>= \response -> do
assertEqual "results are not visible at depth 2" 0 (HashMap.size response)

CutFixture.advanceAllChains_ v (fixture ^. cutFixture)
CutFixture.advanceAllChains_ (fixture ^. cutFixture)

pollingWithDepth v cid clientEnv rks Nothing >>= \response -> do
assertEqual "results are visible at depth 0" 2 (HashMap.size response)
Expand Down Expand Up @@ -243,12 +243,12 @@ spvTest baseRdb = runResourceT $ do
$ defaultCmd

sendReqKey <- fmap NE.head $ sending v srcChain clientEnv (NE.singleton send)
(sendCut, _) <- CutFixture.advanceAllChains v (fixture ^. cutFixture)
(sendCut, _) <- CutFixture.advanceAllChains (fixture ^. cutFixture)
sendCr <- fmap (HashMap.! sendReqKey) $ pollingWithDepth v srcChain clientEnv (NE.singleton sendReqKey) (Just (ConfirmationDepth 0))
let cont = fromMaybe (error "missing continuation") (_crContinuation sendCr)

_ <- replicateM_ 10 $ do
CutFixture.advanceAllChains v (fixture ^. cutFixture)
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
Expand All @@ -271,7 +271,7 @@ spvTest baseRdb = runResourceT $ do
$ set cbGasLimit (GasLimit (Gas 1_000))
$ defaultCmd
recvReqKey <- fmap NE.head $ sending v targetChain clientEnv (NE.singleton recv)
_ <- CutFixture.advanceAllChains v (fixture ^. cutFixture)
_ <- CutFixture.advanceAllChains (fixture ^. cutFixture)
recvCr <- fmap (HashMap.! recvReqKey) $ polling v targetChain clientEnv (NE.singleton recvReqKey)
recvCr
& P.allTrue
Expand Down Expand Up @@ -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
Expand All @@ -397,6 +442,7 @@ invalidTxsTest baseRdb = runResourceT $ do
$ set cbTTL 100
$ defaultCmd
-}

{-
spvTest :: Pact.TxCreationTime -> ClientEnv -> (String -> IO ()) -> IO ()
spvTest t cenv step = do
Expand Down
Loading