Skip to content

Commit

Permalink
Merge pull request #2081 from kadena-io/push-ltuuynlvzttn
Browse files Browse the repository at this point in the history 
Add caplist test
  • Loading branch information
@edmundnoble
edmundnoble authored Dec 18, 2024
2 parents 7b58aa2 + 6cad2cc commit b8a87a0
Show file tree
Hide file tree
Showing 2 changed files with 109 additions and 64 deletions.
13 changes: 6 additions & 7 deletions test/unit/Chainweb/Test/Pact5/CutFixture.hs
View file
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
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

0 comments on commit b8a87a0

Please sign in to comment.