Skip to content

Commit

Permalink
respond to review
Browse files Browse the repository at this point in the history
  • Loading branch information
@chessai
chessai committed Nov 16, 2023
1 parent 5de8d31 commit ebe96f1
Show file tree
Hide file tree
Showing 2 changed files with 87 additions and 95 deletions.
136 changes: 68 additions & 68 deletions test/Chainweb/Test/Pact/RemotePactTest.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -147,9 +147,13 @@ tests rdb = testGroup "Chainweb.Test.Pact.RemotePactTest"
iot = toTxCreationTime <$> iotm
pactDir = do
m <- _getNodeDbDirs <$> net
case M.lookup 0 m of
Just (pactDbDir, _) -> pure pactDbDir
Nothing -> error "impossible"
-- This looks up the pactDbDir for node 0. This is
-- kind of a hack, because there is only one node in
-- this test. However, it doesn't matter much, because
-- we are dealing with both submitting /local txs
-- and compaction, so picking an arbitrary node
-- to run these two operations on is fine.
pure (fst (head m))

in testGroup "remote pact tests"
[ withResourceT (liftIO $ join $ withRequestKeys <$> iot <*> cenv) $ \reqkeys -> golden "remote-golden" $
Expand Down Expand Up @@ -241,48 +245,50 @@ responseGolden cenv rks = do
-- appear in the `txLogs` anymore, and the two should be equivalent.
txlogsCompactionTest :: Pact.TxCreationTime -> ClientEnv -> FilePath -> IO ()
txlogsCompactionTest t cenv pactDbDir = do
createTableTx <- do
let tx = T.unlines
[ "(namespace 'free)"
, "(module m0 G"
, " (defcap G () true)"
, " (defschema person"
, " name:string"
, " age:integer"
, " )"
, " (deftable persons:{person})"
, " (defun read-persons (k) (read persons k))"
, " (defun insert-persons (id name age) (insert persons id { 'name:name, 'age:age }))"
, " (defun write-persons (id name age) (write persons id { 'name:name, 'age:age }))"
, " (defun persons-txlogs (i) (map (txlog persons) (txids persons i)))"
, ")"
, "(create-table persons)"
, "(insert-persons \"A\" \"Lindsey Lohan\" 42)"
, "(insert-persons \"B\" \"Nico Robin\" 30)"
, "(insert-persons \"C\" \"chessai\" 420)"
]
buildTextCmd
$ set cbSigners [mkSigner' sender00 []]
$ set cbGasLimit 300_000
$ set cbTTL defaultMaxTTL
$ set cbCreationTime t
$ set cbChainId cid
$ set cbNetworkId (Just v)
$ mkCmd "createTable-persons"
$ mkExec tx
$ mkKeySetData "sender00" [sender00]
let cmd :: Text -> Text -> CmdBuilder
cmd nonce tx = do
set cbSigners [mkSigner' sender00 []]
$ set cbTTL defaultMaxTTL
$ set cbCreationTime t
$ set cbChainId cid
$ set cbNetworkId (Just v)
$ mkCmd nonce
$ mkExec tx
$ mkKeySetData "sender00" [sender00]

createTableTx <- buildTextCmd
$ set cbGasLimit 300_000
$ cmd "create-table-persons"
$ T.unlines
[ "(namespace 'free)"
, "(module m0 G"
, " (defcap G () true)"
, " (defschema person"
, " name:string"
, " age:integer"
, " )"
, " (deftable persons:{person})"
, " (defun read-persons (k) (read persons k))"
, " (defun insert-persons (id name age) (insert persons id { 'name:name, 'age:age }))"
, " (defun write-persons (id name age) (write persons id { 'name:name, 'age:age }))"
, " (defun persons-txlogs (i) (map (txlog persons) (txids persons i)))"
, ")"
, "(create-table persons)"
, "(insert-persons \"A\" \"Lindsey Lohan\" 42)"
, "(insert-persons \"B\" \"Nico Robin\" 30)"
, "(insert-persons \"C\" \"chessai\" 420)"
]

nonceSupply <- newIORef @Word 1 -- starts at 1 since 0 is always the create-table tx
let nextNonce = do
cur <- readIORef nonceSupply
modifyIORef' nonceSupply (+ 1)
pure cur

let sendTxs txs = flip runClientM cenv $
pactSendApiClient v cid $ SubmitBatch $ NEL.fromList txs

let submitAndCheckTx tx = do
sendTxs [tx] >>= \case
submitResult <- flip runClientM cenv $
pactSendApiClient v cid $ SubmitBatch $ NEL.fromList [tx]
case submitResult of
Left err -> do
assertFailure $ "Error when sending tx: " ++ show err
Right rks -> do
Expand Down Expand Up @@ -315,45 +321,40 @@ txlogsCompactionTest t cenv pactDbDir = do

let createTxLogsTx :: Word -> IO (Command Text)
createTxLogsTx n = do
let txTxt = T.unlines
-- cost is about 360k.
-- cost = flatCost(module) + flatCost(map) + flatCost(txIds) + numTxIds * (costOf(txlog)) + C
-- = 60_000 + 4 + 100_000 + 2 * 100_000 + C
-- = 360_004 + C
-- Note there are two transactions that write to `persons`, which is
-- why `numTxIds` = 2 (and not the number of rows).
let gasLimit = 400_000
buildTextCmd
$ set cbGasLimit gasLimit
$ cmd ("test-txlogs-" <> sshow n)
$ T.unlines
[ "(namespace 'free)"
, "(module m" <> sshow n <> " G"
, " (defcap G () true)"
, " (defun test (i) (m0.persons-txlogs i))"
, " (defun persons-txlogs (i) (m0.persons-txlogs i))"
, ")"
, "(test 0)"
, "(persons-txlogs 0)"
]
buildTextCmd
$ set cbSigners [mkSigner' sender00 []]
$ set cbGasLimit 400_000
$ set cbTTL defaultMaxTTL
$ set cbCreationTime t
$ set cbChainId cid
$ set cbNetworkId (Just v)
$ mkCmd "test-write"
$ mkExec txTxt
$ mkKeySetData "sender00" [sender00]

let createWriteTx :: Word -> IO (Command Text)
createWriteTx n = do
let txTxt = T.unlines
-- module = 60k, write = 100
let gasLimit = 70_000
buildTextCmd
$ set cbGasLimit gasLimit
$ cmd ("test-write-" <> sshow n)
$ T.unlines
[ "(namespace 'free)"
, "(module m" <> sshow n <> " G"
, " (defcap G () true)"
, " (defun test-write (id name age) (m0.write-persons id name age))"
, ")"
, "(test-write \"C\" \"chessai\" 69)"
]
buildTextCmd
$ set cbSigners [mkSigner' sender00 []]
$ set cbGasLimit 100_000
$ set cbTTL defaultMaxTTL
$ set cbCreationTime t
$ set cbChainId cid
$ set cbNetworkId (Just v)
$ mkCmd ("test-write-" <> sshow n)
$ mkExec txTxt
$ mkKeySetData "sender00" [sender00]

let -- This can't be a Map because the RowKeys aren't
-- necessarily unique, unlike in `getLatestPactState`.
Expand All @@ -375,8 +376,7 @@ txlogsCompactionTest t cenv pactDbDir = do
Right txlogs -> do
pure txlogs

writeTx <- createWriteTx =<< nextNonce
submitAndCheckTx writeTx
submitAndCheckTx =<< createWriteTx =<< nextNonce

C.withDefaultLogger Error $ \logger -> do
let flags = [C.NoVacuum, C.NoGrandHash]
Expand All @@ -385,13 +385,13 @@ txlogsCompactionTest t cenv pactDbDir = do
Backend.withSqliteDb cid logger pactDbDir resetDb $ \(SQLiteEnv db _) -> do
void $ C.compact C.Latest logger db flags

txLogsTx <- createTxLogsTx =<< nextNonce
cr <- local cid cenv txLogsTx
txLogs <- crGetTxLogs cr
txLogs <- crGetTxLogs =<< local cid cenv =<< createTxLogsTx =<< nextNonce

latestState <- getLatestState
assertBool "txlogs match latest state" $
txLogs == map (\(rk, rd) -> (rk, J.toJsonViaEncode (_rdData rd))) (M.toList latestState)
assertEqual
"txlogs match latest state"
txLogs
(map (\(rk, rd) -> (rk, J.toJsonViaEncode (_rdData rd))) (M.toList latestState))

localTest :: Pact.TxCreationTime -> ClientEnv -> IO ()
localTest t cenv = do
Expand Down
46 changes: 19 additions & 27 deletions test/Chainweb/Test/Utils.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -135,9 +135,6 @@ import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.Coerce (coerce)
import Data.Foldable
import Data.Map.Strict qualified as Map
import Data.Map.Strict (Map)
import Data.Maybe (mapMaybe)
import qualified Data.HashMap.Strict as HashMap
import Data.IORef
import Data.List (sortOn, isInfixOf)
Expand Down Expand Up @@ -902,7 +899,7 @@ matchTest pat = withArgs ["-p",pat]
data ChainwebNetwork = ChainwebNetwork
{ _getClientEnv :: !ClientEnv
, _getServiceClientEnv :: !ClientEnv
, _getNodeDbDirs :: !(Map Word (FilePath, FilePath))
, _getNodeDbDirs :: ![(FilePath, FilePath)]
}

withNodes_
Expand All @@ -918,10 +915,10 @@ withNodes_ logger v testLabel rdb n = do
(_rkey, (_async, (p2p, service))) <- allocate (start nodeDbDirs) (cancel . fst)
pure (ChainwebNetwork p2p service nodeDbDirs)
where
start :: Map Word (FilePath, FilePath) -> IO (Async (), (ClientEnv, ClientEnv))
start :: [(FilePath, FilePath)] -> IO (Async (), (ClientEnv, ClientEnv))
start dbDirs = do
peerInfoVar <- newEmptyMVar
a <- async $ runTestNodes testLabel rdb logger v n peerInfoVar dbDirs
a <- async $ runTestNodes testLabel rdb logger v peerInfoVar dbDirs
(i, servicePort) <- readMVar peerInfoVar
cwEnv <- getClientEnv $ getCwBaseUrl Https $ _hostAddressPort $ _peerAddr i
cwServiceEnv <- getClientEnv $ getCwBaseUrl Http servicePort
Expand Down Expand Up @@ -999,18 +996,15 @@ runTestNodes
-> RocksDb
-> logger
-> ChainwebVersion
-> Word
-> MVar (PeerInfo, Port)
-> Map Word (FilePath, FilePath)
-> [(FilePath, FilePath)]
-- ^ A Map from Node Id to (Pact DB Dir, RocksDB Dir).
-- The index is just the position in the list.
-> IO ()
runTestNodes testLabel rdb logger ver n portMVar dbDirs = do
let nids = [0 .. n - 1]
let nidWithDirs = mapMaybe (\nid -> (nid,) <$> Map.lookup nid dbDirs) nids

forConcurrently_ nidWithDirs $ \(nid, (pactDbDir, rocksDbDir)) -> do
runTestNodes testLabel rdb logger ver portMVar dbDirs = do
forConcurrently_ (zip [0 ..] dbDirs) $ \(nid, (pactDbDir, rocksDbDir)) -> do
threadDelay (1000 * int nid)
let baseConf = config ver (int n)
let baseConf = config ver (int (length dbDirs))
conf <- if nid == 0
then return $ bootstrapConfig baseConf
else setBootstrapPeerInfo <$> (fst <$> readMVar portMVar) <*> pure baseConf
Expand Down Expand Up @@ -1054,32 +1048,30 @@ node testLabel rdb rawLogger peerInfoVar conf pactDbDir rocksDbDir nid = do
crs = map snd $ HashMap.toList $ view chainwebChains cw
poison cr = mempoolAddToBadList (view chainResMempool cr) (V.singleton deadbeef)

withDbDirs :: Word -> ResourceT IO (Map Word (FilePath, FilePath))
withDbDirs :: Word -> ResourceT IO [(FilePath, FilePath)]
withDbDirs n = do
let create :: IO (Map Word (FilePath, FilePath))
let create :: IO [(FilePath, FilePath)]
create = do
canonicalTmpDirs <- forM [0 .. n - 1] $ \nid -> do
forM [0 .. n - 1] $ \nid -> do
targetDir1 <- getCanonicalTemporaryDirectory
targetDir2 <- getCanonicalTemporaryDirectory
pure (nid, targetDir1, targetDir2)

fmap Map.fromList $ do
forM canonicalTmpDirs $ \(nid, targetDir1, targetDir2) -> do
dir1 <- createTempDirectory targetDir1 ("pactdb-dir-" ++ show nid)
dir2 <- createTempDirectory targetDir2 ("rocksdb-dir-" ++ show nid)
pure (nid, (dir1, dir2))
dir1 <- createTempDirectory targetDir1 ("pactdb-dir-" ++ show nid)
dir2 <- createTempDirectory targetDir2 ("rocksdb-dir-" ++ show nid)

pure (dir1, dir2)

let destroy :: Map Word (FilePath, FilePath) -> IO ()
let destroy :: [(FilePath, FilePath)] -> IO ()
destroy m = flip foldMap m $ \(d1, d2) -> do
ignoringIOErrors $ do
removeDirectoryRecursive d1
removeDirectoryRecursive d2

(_, m) <- allocate create destroy
pure m

ignoringIOErrors :: (MonadCatch m) => m () -> m ()
ignoringIOErrors ioe = ioe `catch` (\e -> const (pure ()) (e :: IOError))
where
ignoringIOErrors :: (MonadCatch m) => m () -> m ()
ignoringIOErrors ioe = ioe `catch` (\(_ :: IOError) -> pure ())

deadbeef :: TransactionHash
deadbeef = TransactionHash "deadbeefdeadbeefdeadbeefdeadbeef"
Expand Down

0 comments on commit ebe96f1

Please sign in to comment.