Merge pull request #335 from mlabs-haskell/chase/test-values

Add ability to create users within `GYTxGameMonad`

src/GeniusYield/Api/TestTokens.hs

@@ -1,3 +1,5 @@
+-- TODO (simplify-genesis): Remove this module once user creation has been removed from test setup.
+-- See note: 'simplify-genesis'.
 {-|
 Module      : GeniusYield.Api.TestTokens
 Copyright   : (c) 2023 GYELD GMBH

src/GeniusYield/Test/Clb.hs

@@ -53,6 +53,7 @@ import           Cardano.Slotting.Slot                          (EpochNo (..),
 import           Cardano.Slotting.Time                          (RelativeTime (RelativeTime),
                                                                  mkSlotLength)
 import           Clb                                            (ClbState (..),
+                                                                 Clb,
                                                                  ClbT,
                                                                  EmulatedLedgerState (..),
                                                                  Log (Log),
@@ -74,6 +75,7 @@ import qualified Clb
 import           Control.Monad.Trans.Maybe                      (runMaybeT)
 import qualified Ouroboros.Consensus.Cardano.Block              as Ouroboros
 import qualified Ouroboros.Consensus.HardFork.History           as Ouroboros
+import           Ouroboros.Consensus.HardFork.History.EraParams (EraParams (eraGenesisWin))
 import qualified PlutusLedgerApi.V2                             as Plutus
 import           Prettyprinter                                  (PageWidth (AvailablePerLine),
                                                                  defaultLayoutOptions,
@@ -93,19 +95,26 @@ import           GeniusYield.TxBuilder.Common
 import           GeniusYield.TxBuilder.Errors
 import           GeniusYield.TxBuilder.User
 import           GeniusYield.Types
-import           Ouroboros.Consensus.HardFork.History.EraParams (EraParams (eraGenesisWin))
 
 deriving newtype instance Num EpochSize
 deriving newtype instance Num EpochNo
 
-type Clb = ClbT ApiEra Identity
+type AtlasClb = Clb ApiEra
 
-newtype GYTxRunEnv = GYTxRunEnv { runEnvWallet :: User }
+newtype GYTxClbEnv = GYTxClbEnv
+    { clbEnvWallet :: User
+    -- ^ The actor for a GYTxMonadClb action.
+    }
+
+newtype GYTxClbState = GYTxClbState
+    { clbNextWalletInt :: Integer
+    -- ^ Next integer to use with 'Clb.intToKeyPair' call in order to generate a new user.
+    }
 
 newtype GYTxMonadClb a = GYTxMonadClb
-    { unGYTxMonadClb :: ReaderT GYTxRunEnv (ExceptT GYTxMonadException (RandT StdGen Clb)) a
+    { unGYTxMonadClb :: ReaderT GYTxClbEnv (StateT GYTxClbState (ExceptT GYTxMonadException (RandT StdGen AtlasClb))) a
     }
-    deriving newtype (Functor, Applicative, Monad, MonadReader GYTxRunEnv)
+    deriving newtype (Functor, Applicative, Monad, MonadReader GYTxClbEnv, MonadState GYTxClbState)
     deriving anyclass GYTxBuilderMonad
 
 instance MonadRandom GYTxMonadClb where
@@ -115,40 +124,45 @@ instance MonadRandom GYTxMonadClb where
     getRandoms  = GYTxMonadClb getRandoms
 
 asRandClb :: User
+          -> Integer
           -> GYTxMonadClb a
-          -> RandT StdGen Clb (Maybe a)
-asRandClb w m = do
-    e <- runExceptT $ unGYTxMonadClb m `runReaderT` GYTxRunEnv w
+          -> RandT StdGen AtlasClb (Maybe a)
+asRandClb w i m = do
+    e <- runExceptT $ (unGYTxMonadClb m `runReaderT` GYTxClbEnv w) `runStateT` GYTxClbState { clbNextWalletInt = i }
     case e of
         Left (GYApplicationException (toApiError -> GYApiError {gaeMsg})) -> lift (logError $ T.unpack gaeMsg) >> return Nothing
         Left err -> lift (logError $ show err) >> return Nothing
-        Right a -> return $ Just a
+        Right (a, _) -> return $ Just a
 
 asClb :: StdGen
       -> User
+      -> Integer
       -> GYTxMonadClb a
-      -> Clb (Maybe a)
-asClb g w m = evalRandT (asRandClb w m) g
+      -> AtlasClb (Maybe a)
+asClb g w i m = evalRandT (asRandClb w i m) g
 
-liftClb :: Clb a -> GYTxMonadClb a
-liftClb = GYTxMonadClb . lift . lift . lift
+liftClb :: AtlasClb a -> GYTxMonadClb a
+liftClb = GYTxMonadClb . lift . lift . lift . lift
 
 {- | Given a test name, runs the trace for every wallet, checking there weren't
      errors.
 -}
 mkTestFor :: String -> (TestInfo -> GYTxMonadClb a) -> Tasty.TestTree
 mkTestFor name action =
     testNoErrorsTraceClb v w Clb.defaultConway name $ do
-      asClb pureGen (w1 testWallets) $ action TestInfo { testGoldAsset = fakeGold, testIronAsset = fakeIron, testWallets }
+      asClb pureGen (w1 testWallets) nextWalletInt
+        $ action TestInfo { testGoldAsset = fakeCoin fakeGold, testIronAsset = fakeCoin fakeIron, testWallets }
   where
-    v = valueFromLovelace 1_000_000_000_000_000 <>
-        fakeGold                  1_000_000_000 <>
-        fakeIron                  1_000_000_000
+    -- TODO (simplify-genesis): Remove generation of non ada funds.
+    v = valueFromLovelace  1_000_000_000_000_000 <>
+        fakeValue fakeGold         1_000_000_000 <>
+        fakeValue fakeIron         1_000_000_000
 
     w = valueFromLovelace 1_000_000_000_000 <>
-        fakeGold                  1_000_000 <>
-        fakeIron                  1_000_000
+        fakeValue fakeGold        1_000_000 <>
+        fakeValue fakeIron        1_000_000
 
+    -- TODO (simplify-genesis):: Remove creation of wallets. Only create one (or more) genesis/funder wallet and pass it on.
     testWallets :: Wallets
     testWallets = Wallets
                       (mkSimpleWallet (Clb.intToKeyPair 1))
@@ -161,8 +175,12 @@ mkTestFor name action =
                       (mkSimpleWallet (Clb.intToKeyPair 8))
                       (mkSimpleWallet (Clb.intToKeyPair 9))
 
+    -- This is the next consecutive number after the highest one used above for 'Clb.intToKeyPair' calls.
+    nextWalletInt :: Integer
+    nextWalletInt = 10
+
     -- | Helper for building tests
-    testNoErrorsTraceClb :: GYValue -> GYValue -> Clb.MockConfig ApiEra -> String -> Clb a -> Tasty.TestTree
+    testNoErrorsTraceClb :: GYValue -> GYValue -> Clb.MockConfig ApiEra -> String -> AtlasClb a -> Tasty.TestTree
     testNoErrorsTraceClb funds walletFunds cfg msg act =
         testCaseInfo msg
             $ maybe (pure mockLog) assertFailure
@@ -176,15 +194,15 @@ mkTestFor name action =
             logString = renderString $ layoutPretty options logDoc
 
 
-    mkSimpleWallet :: TL.KeyPair r L.StandardCrypto -> User
-    mkSimpleWallet kp =
-        let key = paymentSigningKeyFromLedgerKeyPair kp
-        in  User'
-                { userPaymentSKey' = key
-                , userStakeSKey'   = Nothing
-                , userAddr         = addressFromPaymentKeyHash GYTestnetPreprod . paymentKeyHash $
-                    paymentVerificationKey key
-                }
+mkSimpleWallet :: TL.KeyPair r L.StandardCrypto -> User
+mkSimpleWallet kp =
+    let key = paymentSigningKeyFromLedgerKeyPair kp
+    in  User'
+            { userPaymentSKey' = key
+            , userStakeSKey'   = Nothing
+            , userAddr         = addressFromPaymentKeyHash GYTestnetPreprod . paymentKeyHash $
+                paymentVerificationKey key
+            }
 
 {- | Try to execute an action, and if it fails, restore to the current state
  while preserving logs. If the action succeeds, logs an error as we expect
@@ -334,12 +352,12 @@ instance GYTxQueryMonad GYTxMonadClb where
 
 instance GYTxUserQueryMonad GYTxMonadClb where
 
-    ownAddresses = asks $ userAddresses' . runEnvWallet
+    ownAddresses = asks $ userAddresses' . clbEnvWallet
 
-    ownChangeAddress = asks $ userChangeAddress . runEnvWallet
+    ownChangeAddress = asks $ userChangeAddress . clbEnvWallet
 
     ownCollateral = runMaybeT $ do
-        UserCollateral {userCollateralRef, userCollateralCheck} <- asks (userCollateral . runEnvWallet) >>= hoistMaybe
+        UserCollateral {userCollateralRef, userCollateralCheck} <- asks (userCollateral . clbEnvWallet) >>= hoistMaybe
         collateralUtxo <- lift $ utxoAtTxOutRef userCollateralRef
             >>= maybe (throwError . GYQueryUTxOException $ GYNoUtxoAtRef userCollateralRef) pure
         if not userCollateralCheck || (utxoValue collateralUtxo == collateralValue) then pure collateralUtxo
@@ -366,8 +384,8 @@ instance GYTxUserQueryMonad GYTxMonadClb where
                 Just (ref, _) -> return ref
 
 instance GYTxMonad GYTxMonadClb where
-    signTxBody = signTxBodyImpl . asks $ userPaymentSKey . runEnvWallet
-    signTxBodyWithStake = signTxBodyWithStakeImpl $ asks ((,) . userPaymentSKey . runEnvWallet) <*> asks (userStakeSKey . runEnvWallet)
+    signTxBody = signTxBodyImpl . asks $ userPaymentSKey . clbEnvWallet
+    signTxBodyWithStake = signTxBodyWithStakeImpl $ asks ((,) . userPaymentSKey . clbEnvWallet) <*> asks (userStakeSKey . clbEnvWallet)
     submitTx tx = do
         let txBody = getTxBody tx
         dumpBody txBody
@@ -411,9 +429,17 @@ instance GYTxMonad GYTxMonadClb where
 
 instance GYTxGameMonad GYTxMonadClb where
     type TxMonadOf GYTxMonadClb = GYTxMonadClb
+    createUser = do
+        st <- get
+        let i = clbNextWalletInt st
+            user = mkSimpleWallet $ Clb.intToKeyPair i
+        gyLogDebug' "createUser" . T.unpack $ "Created simple user with address: " <> addressToText (userAddr user)
+        put st { clbNextWalletInt = i + 1 }
+        pure user
     asUser u act = do
+        -- Overwrite the own user and perform the action.
         local
-            (const $ GYTxRunEnv u)
+            (\x -> x { clbEnvWallet = u })
             act
 
 slotConfig' :: GYTxMonadClb (UTCTime, NominalDiffTime)

src/GeniusYield/Test/FakeCoin.hs

@@ -4,45 +4,46 @@
 {-# OPTIONS -fno-strictness -fno-spec-constr -fno-specialise #-}
 {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:target-version=1.0.0 #-}
 
-module GeniusYield.Test.FakeCoin (FakeCoin (..), fakeValue, fakeCoin) where
+module GeniusYield.Test.FakeCoin (FakeCoin (..), fakeValue, fakeCoin, fakePolicy) where
 
-import qualified Cardano.Api                 as Api
-import qualified Cardano.Api.Shelley         as Api.S
 import           PlutusCore.Core             (plcVersion100)
 import qualified PlutusLedgerApi.V1.Value    as PlutusValue
 import           PlutusLedgerApi.V2
 import           PlutusLedgerApi.V2.Contexts (ownCurrencySymbol)
 import qualified PlutusTx
 import           PlutusTx.Prelude
 
+import           GeniusYield.Types
+
 -- | Test assets.
-newtype FakeCoin = FakeCoin { fakeCoin'tag :: BuiltinByteString }
+newtype FakeCoin = FakeCoin { fakeCoinName :: GYTokenName }
+
+fakePolicy :: FakeCoin -> GYMintingPolicy PlutusV2
+fakePolicy = fakeMintingPolicy . fakeCoinName
 
-fakeValue :: FakeCoin -> Integer -> Value
-fakeValue tag = PlutusValue.assetClassValue (fakeCoin tag)
+fakeValue :: FakeCoin -> Integer -> GYValue
+fakeValue tag = valueSingleton (fakeCoin tag)
 
 -- | Fake coin class generated from fixed tag.
-fakeCoin :: FakeCoin -> PlutusValue.AssetClass
-fakeCoin (FakeCoin tag) = PlutusValue.assetClass sym tok
-  where
-    sym =
-      CurrencySymbol $ toBuiltin $
-        Api.serialiseToRawBytes $ Api.hashScript $ Api.PlutusScript Api.PlutusScriptV2
-          $ Api.S.PlutusScriptSerialised $ serialiseCompiledCode $ fakeMintingPolicy tok
-    tok = TokenName tag
-
-fakeMintingPolicy :: TokenName -> PlutusTx.CompiledCode (BuiltinData -> BuiltinData -> BuiltinUnit)
-fakeMintingPolicy mintParam =
+fakeCoin :: FakeCoin -> GYAssetClass
+fakeCoin (FakeCoin tag) = mintingPolicyId (fakeMintingPolicy tag) `GYToken` tag
+
+fakeMintingPolicy :: GYTokenName -> GYMintingPolicy PlutusV2
+fakeMintingPolicy = mintingPolicyFromPlutus . fakeMintingPolicyPlutus . tokenNameToPlutus
+
+fakeMintingPolicyPlutus :: TokenName -> PlutusTx.CompiledCode (BuiltinData -> BuiltinData -> ())
+fakeMintingPolicyPlutus mintParam =
   $$(PlutusTx.compile [|| fakeMintingPolicyUntypedContract ||]) `PlutusTx.unsafeApplyCode` PlutusTx.liftCode plcVersion100 mintParam
 
 -- | Can mint new coins if token name equals to fixed tag.
 {-# INLINEABLE fakeMintingPolicyContract #-}
 fakeMintingPolicyContract :: TokenName -> () -> ScriptContext -> Bool
 fakeMintingPolicyContract tag _ ctx =
-  PlutusValue.valueOf (txInfoMint (scriptContextTxInfo ctx)) (ownCurrencySymbol ctx) tag > 0
+  PlutusValue.valueOf (txInfoMint (scriptContextTxInfo ctx)) (ownCurrencySymbol ctx) tag /= 0
 
 -- | See `fakeMintingPolicyContract`.
 {-# INLINEABLE fakeMintingPolicyUntypedContract #-}
-fakeMintingPolicyUntypedContract :: TokenName -> BuiltinData -> BuiltinData -> BuiltinUnit
-fakeMintingPolicyUntypedContract tag red ctx = check
-    (fakeMintingPolicyContract tag (unsafeFromBuiltinData red) (unsafeFromBuiltinData ctx))
+fakeMintingPolicyUntypedContract :: TokenName -> BuiltinData -> BuiltinData -> ()
+fakeMintingPolicyUntypedContract tag red ctx
+  | fakeMintingPolicyContract tag (unsafeFromBuiltinData red) (unsafeFromBuiltinData ctx) = ()
+  | otherwise = error ()

src/GeniusYield/Test/FeeTracker.hs

@@ -174,6 +174,7 @@ ftgLift act = FeeTrackerGame $ \s -> (, s) <$> act
 
 instance GYTxGameMonad m => GYTxGameMonad (FeeTrackerGame m) where
     type TxMonadOf (FeeTrackerGame m) = FeeTracker (TxMonadOf m)
+    createUser = ftgLift createUser
     asUser u (FeeTracker act) = FeeTrackerGame $ asUser u . act
 
 {- Note [Proper GYTxMonad overriding with FeeTracker]

src/GeniusYield/Test/Privnet/Ctx.hs

@@ -47,6 +47,7 @@ import           GeniusYield.Types
 import           GeniusYield.Test.Utils
 import           Test.Tasty.HUnit           (assertFailure)
 
+-- TODO (simplify-genesis): Remove this once 'newTempUserCtx' has been removed.
 data CreateUserConfig =
      CreateUserConfig
        { -- | Create collateral output of 5 ada?
@@ -63,6 +64,8 @@ data Ctx = Ctx
     { ctxNetworkInfo       :: !GYNetworkInfo
     , ctxInfo              :: !Api.LocalNodeConnectInfo
     -- FIXME: There are now multiple genesis users (since cardano-testnet usage).
+    -- TODO (simplify-genesis): Remove these fields (except for funder user(s))
+    -- once user creation logic is removed from test setup.
     , ctxUserF             :: !User  -- ^ Funder. All other users begin with same status of funds.
     , ctxUser2             :: !User
     , ctxUser3             :: !User
@@ -84,11 +87,13 @@ data Ctx = Ctx
 ctxNetworkId :: Ctx -> GYNetworkId
 ctxNetworkId Ctx {ctxNetworkInfo} = GYPrivnet ctxNetworkInfo
 
+-- TODO (simplify-genesis): Remove this once user creation logic is removed from test setup.
 -- | List of context sibling users - all of which begin with same balance.
 -- FIXME: Some of these users are actually genesis users.
 ctxUsers :: Ctx -> [User]
 ctxUsers ctx = ($ ctx) <$> [ctxUser2, ctxUser3, ctxUser4, ctxUser5, ctxUser6, ctxUser7, ctxUser8, ctxUser9]
 
+-- TODO (simplify-genesis): Remove this once user creation logic is removed from test setup.
 ctxWallets :: Ctx -> Wallets
 ctxWallets Ctx{..} = Wallets
   { w1 = ctxUserF
@@ -102,6 +107,7 @@ ctxWallets Ctx{..} = Wallets
   , w9 = ctxUser9
   }
 
+-- TODO (simplify-genesis): Remove this. See note 'simplify-genesis'.
 -- | Creates a new user with the given balance. Note that the actual balance which this user get's could be more than what is provided to satisfy minimum ada requirement of a UTxO.
 newTempUserCtx:: Ctx
               -> User            -- ^ User which will fund this new user.

src/GeniusYield/Test/Privnet/Setup.hs

@@ -348,6 +348,7 @@ withPrivnet testnetOpts setupUser = do
 -- Generating users
 -------------------------------------------------------------------------------
 
+-- TODO (simplify-genesis): Remove this. See note 'simplify-genesis'.
 generateUser :: GYNetworkId -> IO User
 generateUser network = do
     -- generate new key
@@ -374,12 +375,14 @@ generateUser network = do
 -- Balance
 -------------------------------------------------------------------------------
 
+-- TODO (simplify-genesis): Remove this once 'generateUser' and similar have been removed. Use 'createUserWithLovelace' instead.
 giveAda :: Ctx -> GYAddress -> IO ()
 giveAda ctx addr = ctxRun ctx (ctxUserF ctx) $ do
     txBody <- buildTxBody $ mconcat $ replicate 5 $
         mustHaveOutput $ mkGYTxOutNoDatum addr (valueFromLovelace 1_000_000_000)
     signAndSubmitConfirmed_ txBody
 
+-- TODO (simplify-genesis): Remove this once 'generateUser' and similar have been removed. Use 'createUserWithAssets' instead.
 giveTokens :: Ctx -> GYAddress -> IO ()
 giveTokens ctx addr = ctxRun ctx (ctxUserF ctx) $ do
     txBody <- buildTxBody $
@@ -391,6 +394,7 @@ giveTokens ctx addr = ctxRun ctx (ctxUserF ctx) $ do
 -- minting tokens
 -------------------------------------------------------------------------------
 
+-- TODO (simplify-genesis): Remove this once 'generateUser' and similar have been removed.
 mintTestTokens :: Ctx -> String -> IO GYAssetClass
 mintTestTokens ctx tn' = do
     ctxRun ctx (ctxUserF ctx) $ do