From 6d09a525d27fdadfa9135b9ba71596e0dbc8e1e4 Mon Sep 17 00:00:00 2001 From: euonymos Date: Tue, 10 Sep 2024 21:24:36 -0600 Subject: [PATCH] feat: tasty-compatible withPrivnet BROKEN --- src/GeniusYield/Providers/LiteChainIndex.hs | 1 + src/GeniusYield/Test/Privnet/Setup.hs | 197 ++++++++++++++++++ .../Test/Unified/BetRef/PlaceBet.hs | 21 +- tests-unified/atlas-unified-tests.hs | 47 +++-- 4 files changed, 244 insertions(+), 22 deletions(-) diff --git a/src/GeniusYield/Providers/LiteChainIndex.hs b/src/GeniusYield/Providers/LiteChainIndex.hs index 52e1d863..9f7fc1e3 100644 --- a/src/GeniusYield/Providers/LiteChainIndex.hs +++ b/src/GeniusYield/Providers/LiteChainIndex.hs @@ -92,6 +92,7 @@ lciWaitUntilSlot (LCIClient _ slotVar _) (slotToApi -> slot) = STM.atomically $ lookupApiDatum :: LCIClient -> Api.Hash Api.ScriptData -> IO (Maybe Api.HashableScriptData) lookupApiDatum (LCIClient _ _ dataVar) h = do m <- STM.readTVarIO dataVar + putStrLn $ "lookupApiDatum: " <> show m return $ Map.lookup h m lciLookupDatum :: LCIClient -> GYLookupDatum diff --git a/src/GeniusYield/Test/Privnet/Setup.hs b/src/GeniusYield/Test/Privnet/Setup.hs index ae722eaa..2070df33 100644 --- a/src/GeniusYield/Test/Privnet/Setup.hs +++ b/src/GeniusYield/Test/Privnet/Setup.hs @@ -8,6 +8,7 @@ Stability : develop module GeniusYield.Test.Privnet.Setup ( Setup, withPrivnet, + withPrivnet', withSetup, withSetup', withSetupOld, @@ -22,6 +23,7 @@ module GeniusYield.Test.Privnet.Setup ( TestnetNodeOptions (..), NodeLoggingFormat (..), NodeConfigurationYaml (..), + mkPrivnetTestFor'', ) where import Cardano.Api qualified as Api @@ -63,6 +65,11 @@ import Test.Tasty.HUnit (testCaseSteps) import Testnet.Property.Util import Testnet.Types +-- import System.IO.Temp ( +-- createTempDirectory, +-- getCanonicalTemporaryDirectory, +-- ) + ------------------------------------------------------------------------------- -- Setup ------------------------------------------------------------------------------- @@ -106,6 +113,16 @@ mkPrivnetTestFor' :: TestName -> GYLogSeverity -> Setup -> (TestInfo -> GYTxGame mkPrivnetTestFor' name targetSev setup action = testCaseSteps name $ \info -> withSetup' targetSev info setup $ \ctx -> do ctxRunGame ctx $ action TestInfo {testGoldAsset = ctxGold ctx, testIronAsset = ctxIron ctx, testWallets = ctxWallets ctx} +mkPrivnetTestFor'' :: TestName -> GYLogSeverity -> IO (Setup, ThreadId) -> (TestInfo -> GYTxGameMonadIO ()) -> TestTree +mkPrivnetTestFor'' name targetSev getSetup action = + testCaseSteps name $ + \info -> getSetup >>= \(setup, _) -> withSetup' targetSev info setup $ + \ctx -> ctxRunGame ctx $ action + TestInfo + { testGoldAsset = ctxGold ctx + , testIronAsset = ctxIron ctx + , testWallets = ctxWallets ctx} + {- TODO: WIP: Provide a variant of `withSetup` that can access `Ctx` to return a non-unit result. TODO: Can below implementation also accept @putLog@? @@ -361,6 +378,186 @@ withPrivnet testnetOpts setupUser = do (startTime, shelleyGenesis') <- getDefaultShelleyGenesis opts cardanoTestnet opts conf startTime shelleyGenesis' alonzoGenesis conwayGenesis +withPrivnet' :: CardanoTestnetOptions -> IO (Setup, ThreadId) +withPrivnet' testnetOpts = do + -- Based on: https://github.com/IntersectMBO/cardano-node/blob/master/cardano-testnet/src/Testnet/Property/Run.hs + -- They are using hedgehog (property testing framework) to orchestrate a testnet running in the background + -- ....for some god forsaken reason + -- the result is very awkward. + tmvRuntime <- STM.newEmptyTMVarIO + + void . H.check $ integrationWorkspace "tn" $ \workspaceDir -> do + conf <- mkConf workspaceDir + + -- Fork a thread to keep alive indefinitely any resources allocated by testnet. + threadId <- H.evalM . liftResourceT . resourceForkIO . forever . liftIO $ threadDelay 10000000 + + TestnetRuntime + { wallets + , poolNodes + , testnetMagic + } <- + cardanoTestnet' testnetOpts conf + + liftIO . STM.atomically $ + STM.writeTMVar + tmvRuntime + PrivnetRuntime + { -- TODO: Consider obtaining everything here from shelleyGenesis rather than testnetOpts. + -- See: https://www.doitwithlovelace.io/haddock/cardano-ledger-shelley/html/Cardano-Ledger-Shelley-Genesis.html + -- See: https://github.com/IntersectMBO/cardano-node/blob/43149909fc4942e93e14a2686826543a2d9432bf/cardano-testnet/src/Testnet/Types.hs#L155 + runtimeNodeSocket = + H'.sprocketSystemName + . nodeSprocket + . poolRuntime + $ head poolNodes + , runtimeNetworkInfo = + GYNetworkInfo + { gyNetworkEpochSlots = fromIntegral $ cardanoEpochLength testnetOpts + , gyNetworkMagic = fromIntegral testnetMagic + } + , runtimeWallets = wallets + , runtimeThreadId = threadId + } + + -- Forced failure (just like upstream). + -- For some god forsaken reason, not making this whole thing fail makes the node workspace directory disappear and the nodes not run. + -- Assumption: Hedgehog clears the workspace (since it's temp) in case of success. + -- No clue why the nodes don't run. Laziness? + H.failure + + PrivnetRuntime + { runtimeNodeSocket + , runtimeNetworkInfo + , runtimeWallets + , runtimeThreadId + } <- + STM.atomically $ STM.readTMVar tmvRuntime + + let runtimeNetworkId = GYPrivnet runtimeNetworkInfo + + -- Kill the resource holding thread at the end of all this to stop the privnet. + -- (`finally` killThread runtimeThreadId) $ do + -- Read pre-existing users. + -- NOTE: As of writing, cardano-testnet creates three (3) users. + genesisUsers <- fmap V.fromList . liftIO . forM (zip [1 :: Int ..] runtimeWallets) $ + \(idx, PaymentKeyInfo {paymentKeyInfoPair, paymentKeyInfoAddr}) -> do + debug $ printf "userF = %s\n" (show idx) + userAddr <- addressFromBech32 <$> urlPieceFromText paymentKeyInfoAddr + debug $ printf "userF addr = %s\n" userAddr + userPaymentSKey' <- readPaymentSigningKey $ Api.unFile $ signingKey paymentKeyInfoPair + debug $ printf "userF skey = %s\n" userPaymentSKey' + pure User' {userPaymentSKey', userStakeSKey' = Nothing, userAddr} + + -- Generate upto 9 users. + let extraIndices = [length genesisUsers + 1 .. 9] + extraUsers <- fmap V.fromList . forM extraIndices $ \idx -> do + User' {userPaymentSKey', userAddr, userStakeSKey'} <- generateUser runtimeNetworkId + debug $ printf "user = %s\n" (show idx) + debug $ printf "user addr = %s\n" userAddr + debug $ printf "user skey = %s\n" (show userPaymentSKey') + debug $ printf "user vkey = %s\n" (show $ paymentVerificationKey userPaymentSKey') + debug $ printf "user pkh = %s\n" (show $ paymentKeyHash $ paymentVerificationKey userPaymentSKey') + pure User' {userPaymentSKey', userAddr, userStakeSKey'} + + -- Further down we need local node connection + let info :: Api.LocalNodeConnectInfo + info = + Api.LocalNodeConnectInfo + { Api.localConsensusModeParams = Api.CardanoModeParams . Api.EpochSlots $ gyNetworkEpochSlots runtimeNetworkInfo + , Api.localNodeNetworkId = networkIdToApi runtimeNetworkId + , Api.localNodeSocketPath = Api.File runtimeNodeSocket + } + + -- ask current slot, so we know local node connection works + slot <- nodeGetSlotOfCurrentBlock info + debug $ printf "slotOfCurrentBlock = %s\n" slot + + withLCIClient info [] $ \lci -> do + let localLookupDatum :: GYLookupDatum + localLookupDatum = lciLookupDatum lci + + let localAwaitTxConfirmed :: GYAwaitTx + localAwaitTxConfirmed = nodeAwaitTxConfirmed info + + let localQueryUtxo :: GYQueryUTxO + localQueryUtxo = nodeQueryUTxO info + + localGetParams <- nodeGetParameters info + + -- context used for tests + -- + let allUsers = genesisUsers <> extraUsers + let ctx0 :: Ctx + ctx0 = + Ctx + { ctxNetworkInfo = runtimeNetworkInfo + , ctxInfo = info + , -- FIXME: Some of the users which are supposed to be non genesis are actually genesis. + -- This is because we have multiple genesis users with cardano testnet. + -- Need a better (more dynamic mechanism for users). + ctxUserF = V.head allUsers + , ctxUser2 = allUsers V.! 1 + , ctxUser3 = allUsers V.! 2 + , ctxUser4 = allUsers V.! 3 + , ctxUser5 = allUsers V.! 4 + , ctxUser6 = allUsers V.! 5 + , ctxUser7 = allUsers V.! 6 + , ctxUser8 = allUsers V.! 7 + , ctxUser9 = allUsers V.! 8 + , ctxGold = GYLovelace -- temporarily + , ctxIron = GYLovelace -- temporarily + , ctxLog = noLogging + , ctxLookupDatum = localLookupDatum + , ctxAwaitTxConfirmed = localAwaitTxConfirmed + , ctxQueryUtxos = localQueryUtxo + , ctxGetParams = localGetParams + } + + V.imapM_ + ( \i User' {userAddr = userIaddr} -> do + userIbalance <- ctxRunQuery ctx0 $ queryBalance userIaddr + when (isEmptyValue userIbalance) $ do + debug $ printf "User %d balance is empty, giving some ada\n" $ i + 1 + giveAda ctx0 userIaddr + when (i == 0) (giveAda ctx0 . userAddr $ ctxUserF ctx0) -- we also give ada to itself to create some small utxos + ) + allUsers + + -- mint test tokens + goldAC <- mintTestTokens ctx0 "GOLD" + debug $ printf "gold = %s\n" goldAC + + ironAC <- mintTestTokens ctx0 "IRON" + debug $ printf "iron = %s\n" ironAC + + let ctx :: Ctx + ctx = + ctx0 + { ctxGold = goldAC + , ctxIron = ironAC + } + + -- distribute tokens + V.imapM_ + ( \i User' {userAddr = userIaddr} -> do + userIbalance <- ctxRunQuery ctx0 $ queryBalance userIaddr + when (isEmptyValue $ snd $ valueSplitAda userIbalance) $ do + debug $ printf "User %d has no tokens, giving some\n" $ i + 1 + giveTokens ctx userIaddr + ) + allUsers + + let setup = Setup $ \targetSev putLog kont -> kont $ ctx {ctxLog = simpleLogging targetSev (putLog . Txt.unpack)} + pure (setup, runtimeThreadId) + where + -- \| This is defined same as `cardanoTestnetDefault` except we use our own conway genesis parameters. + cardanoTestnet' opts conf = do + Api.AnyCardanoEra cEra <- pure $ cardanoNodeEra cardanoDefaultTestnetOptions + alonzoGenesis <- getDefaultAlonzoGenesis cEra + (startTime, shelleyGenesis') <- getDefaultShelleyGenesis opts + cardanoTestnet opts conf startTime shelleyGenesis' alonzoGenesis conwayGenesis + ------------------------------------------------------------------------------- -- Generating users ------------------------------------------------------------------------------- diff --git a/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs b/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs index ca4ed04f..5505450a 100644 --- a/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs +++ b/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs @@ -25,6 +25,7 @@ import GeniusYield.Test.Unified.OnChain.BetRef.Compiled import GeniusYield.Test.Utils import GeniusYield.TxBuilder import GeniusYield.Types +import Control.Concurrent (ThreadId) {- | Test environment 'WalletInfo' among other things provides nine wallets that be used in tests. For convinience we assign some meaningful names to them. @@ -46,23 +47,23 @@ placeBetTestsClb = ] -- | Test suite for a private testnet -placeBetTests :: Setup -> TestTree -placeBetTests setup = +placeBetTests :: IO (Setup, ThreadId) -> TestTree +placeBetTests getSetup = testGroup "Place bet" [ mkPrivnetTestFor_ "Simple tx" simpleTxTest , mkPrivnetTestFor_ "Placing first bet" firstBetTest' , mkPrivnetTestFor_ "Multiple bets" multipleBetsTest - , mkPrivnetTestFor' "Multiple bets - too small step" GYDebug setup $ - handleError - ( \case - GYBuildTxException GYBuildTxBodyErrorAutoBalance {} -> pure () - e -> throwError e - ) - . failingMultipleBetsTest + -- , mkPrivnetTestFor' "Multiple bets - too small step" GYDebug setup $ + -- handleError + -- ( \case + -- GYBuildTxException GYBuildTxBodyErrorAutoBalance {} -> pure () + -- e -> throwError e + -- ) + -- . failingMultipleBetsTest ] where - mkPrivnetTestFor_ = flip mkPrivnetTestFor setup + mkPrivnetTestFor_ name= mkPrivnetTestFor'' name GYDebug getSetup -- ----------------------------------------------------------------------------- -- Simple tx diff --git a/tests-unified/atlas-unified-tests.hs b/tests-unified/atlas-unified-tests.hs index c0ab37f2..55484cde 100644 --- a/tests-unified/atlas-unified-tests.hs +++ b/tests-unified/atlas-unified-tests.hs @@ -4,26 +4,49 @@ module Main ( import Test.Tasty ( defaultMain, - testGroup, + testGroup, withResource, ) import GeniusYield.Test.Privnet.Setup import GeniusYield.Test.Unified.BetRef.PlaceBet import GeniusYield.Test.Unified.BetRef.TakePot +import Control.Concurrent (killThread) + + +-- main :: IO () +-- main = do +-- withPrivnet cardanoDefaultTestnetOptionsConway $ \setup -> +-- defaultMain $ +-- testGroup "Atlas Unified Tests" +-- [ +-- -- testGroup "Emulator" +-- -- [ placeBetTestsClb +-- -- , takeBetPotTestsClb +-- -- ] +-- -- , +-- testGroup "Privnet" +-- [ placeBetTests $ pure (setup, undefined) +-- -- , takeBetPotTests setup +-- ] +-- ] + main :: IO () main = do - defaultMain $ - testGroup - "Emulator" - [ placeBetTestsClb - , takeBetPotTestsClb - ] - withPrivnet cardanoDefaultTestnetOptionsConway $ \setup -> defaultMain $ - testGroup - "Privnet" - [ placeBetTests setup - , takeBetPotTests setup + testGroup "Atlas Unified Tests" + [ testGroup "Emulator" + [ placeBetTestsClb + , takeBetPotTestsClb + ] + , withResource + (withPrivnet' cardanoDefaultTestnetOptionsConway) + (\(_, threadId) -> putStrLn ("killing thread: " <> show threadId) + *> killThread threadId) + $ \getSetup -> testGroup "Privnet" + [ placeBetTests getSetup + -- , takeBetPotTests setup + ] ] +