feat: update to coin selection and tx build strategy to incorporate u…

…pdate of certificates and withdrawals Related to #294.
geniusyield · Apr 26, 2024 · cbd2aa5 · cbd2aa5
1 parent 28e9059
commit cbd2aa5
Show file tree

Hide file tree

Showing 6 changed files with 92 additions and 21 deletions.
diff --git a/atlas-cardano.cabal b/atlas-cardano.cabal
@@ -312,7 +312,7 @@ test-suite atlas-privnet-tests
   ghc-options:    -threaded -rtsopts
   hs-source-dirs: tests-privnet
   main-is:        atlas-privnet-tests.hs
-  other-modules:
+  other-modules:  GeniusYield.Test.Privnet.Stake
 
   -- Dependencies inherited from the library. No need to specify bounds.
   build-depends:

diff --git a/src/GeniusYield/Transaction.hs b/src/GeniusYield/Transaction.hs
@@ -65,6 +65,7 @@ import           Data.Foldable                         (Foldable (foldMap'),
 import           Data.List                             (delete)
 import qualified Data.Map                              as Map
 import           Data.Ratio                            ((%))
+import qualified Data.Set                              as Set
 
 import           Data.Either.Combinators               (maybeToRight)
 import           Data.Maybe                            (fromJust)
@@ -75,6 +76,7 @@ import qualified Cardano.Ledger.Alonzo.Scripts         as AlonzoScripts
 import qualified Cardano.Ledger.Alonzo.Tx              as AlonzoTx
 import           Cardano.Slotting.Time                 (SystemStart)
 
+import qualified Cardano.Api.Shelley                   as Api
 import           Cardano.Ledger.Core                   (EraTx (sizeTxF))
 import           Control.Lens                          (view)
 import           Control.Monad.Random
@@ -337,11 +339,12 @@ finalizeGYBalancedTx
         collaterals
         ss
         eh
-        pp
+        unbundledPP
         ps
         (utxosToApi utxos)
         body
         changeAddr
+        unregisteredStakeCredsMap
   where
 
     inRefs :: Api.TxInsReference Api.BuildTx Api.BabbageEra
@@ -442,6 +445,12 @@ finalizeGYBalancedTx
                   ) (mempty, mempty) certs
           in Api.TxCertificates Api.S.CertificatesInBabbageEra (reverse $ fst apiCertsFromGY) $ Api.BuildTxWith (snd apiCertsFromGY)
 
+    unbundledPP = Api.S.unbundleProtocolParams pp
+
+    ppStakeAddressDeposit = fromIntegral $ Api.S.protocolParamStakeAddressDeposit unbundledPP
+
+    unregisteredStakeCredsMap = Map.fromList [ (stakeCredentialToApi sc, ppStakeAddressDeposit) | GYStakeAddressDeregistrationCertificate sc  <- map gyTxCertCertificate certs]
+
     body :: Api.TxBodyContent Api.BuildTx Api.BabbageEra
     body = Api.TxBodyContent
         ins'
@@ -455,7 +464,7 @@ finalizeGYBalancedTx
         txMetadata
         Api.TxAuxScriptsNone
         extra
-        (Api.BuildTxWith $ Just $ Api.S.unbundleProtocolParams pp)
+        (Api.BuildTxWith $ Just unbundledPP)
         wdrls'
         certs'
         Api.TxUpdateProposalNone
@@ -469,34 +478,37 @@ If not checked, the returned txbody may fail during submission.
 makeTransactionBodyAutoBalanceWrapper :: GYUTxOs
                                       -> SystemStart
                                       -> Api.S.EraHistory Api.S.CardanoMode
-                                      -> Api.S.BundledProtocolParameters Api.S.BabbageEra
+                                      -> Api.ProtocolParameters
                                       -> Set Api.S.PoolId
                                       -> Api.S.UTxO Api.S.BabbageEra
                                       -> Api.S.TxBodyContent Api.S.BuildTx Api.S.BabbageEra
                                       -> GYAddress
+                                      -> Map.Map Api.StakeCredential Api.Lovelace
                                       -> Int
                                       -> Either BuildTxException GYTxBody
-makeTransactionBodyAutoBalanceWrapper collaterals ss eh pp ps utxos body changeAddr numSkeletonOuts = do
+makeTransactionBodyAutoBalanceWrapper collaterals ss eh unbundledPP _ps utxos body changeAddr stakeDelegDeposits numSkeletonOuts = do
+    let poolids = Set.empty -- TODO: This denotes the set of registered stake pools, that are being unregistered in this transaction.
+        nkeys = Api.estimateTransactionKeyWitnessCount body
+
     Api.ExecutionUnits
         { executionSteps  = maxSteps
         , executionMemory = maxMemory
-        } <- maybeToRight BuildTxMissingMaxExUnitsParam $ Api.S.protocolParamMaxTxExUnits $ Api.S.unbundleProtocolParams pp
-    let maxTxSize = Api.S.protocolParamMaxTxSize $ Api.S.unbundleProtocolParams pp
+        } <- maybeToRight BuildTxMissingMaxExUnitsParam $ Api.S.protocolParamMaxTxExUnits unbundledPP
+    let maxTxSize = Api.S.protocolParamMaxTxSize unbundledPP
         changeAddrApi :: Api.S.AddressInEra Api.S.BabbageEra = addressToApi' changeAddr
-        stakeDelegDeposits = mempty  -- TODO: Currently it's empty as we don't support for unregistration!
 
     -- First we obtain the calculated fees to correct for our collaterals.
     bodyBeforeCollUpdate@(Api.BalancedTxBody _ _ _ (Api.Lovelace feeOld)) <-
       first BuildTxBodyErrorAutoBalance $ Api.makeTransactionBodyAutoBalance
         ss
         (Api.toLedgerEpochInfo eh)
-        (Api.S.unbundleProtocolParams pp)
-        ps
+        unbundledPP
+        poolids
         stakeDelegDeposits
         utxos
         body
         changeAddrApi
-        Nothing
+        (Just nkeys)
 
     -- We should call `makeTransactionBodyAutoBalance` again with updated values of collaterals so as to get slightly lower fee estimate.
     Api.BalancedTxBody txBodyContent txBody extraOut _ <- if collaterals == mempty then return bodyBeforeCollUpdate else
@@ -505,7 +517,7 @@ makeTransactionBodyAutoBalanceWrapper collaterals ss eh pp ps utxos body changeA
 
         collateralTotalValue :: GYValue = foldMapUTxOs utxoValue collaterals
         collateralTotalLovelace :: Integer = fst $ valueSplitAda collateralTotalValue
-        balanceNeeded :: Integer = ceiling $ (feeOld * toInteger (fromJust $ Api.S.protocolParamCollateralPercent $ Api.S.unbundleProtocolParams pp)) % 100
+        balanceNeeded :: Integer = ceiling $ (feeOld * toInteger (fromJust $ Api.S.protocolParamCollateralPercent unbundledPP)) % 100
 
       in do
 
@@ -521,13 +533,13 @@ makeTransactionBodyAutoBalanceWrapper collaterals ss eh pp ps utxos body changeA
         first BuildTxBodyErrorAutoBalance $ Api.makeTransactionBodyAutoBalance
           ss
           (Api.toLedgerEpochInfo eh)
-          (Api.S.unbundleProtocolParams pp)
-          ps
+          unbundledPP
+          poolids
           stakeDelegDeposits
           utxos
           body {Api.txTotalCollateral = txColl, Api.txReturnCollateral = collRet}
           changeAddrApi
-          Nothing
+          (Just nkeys)
 
     let Api.S.ShelleyTx _ ltx = Api.Tx txBody []
         -- This sums up the ExUnits for all embedded Plutus Scripts anywhere in the transaction:
@@ -561,9 +573,9 @@ collapseExtraOut
   :: Api.TxOut Api.S.CtxTx Api.S.BabbageEra
   -- ^ The extra output generated by @makeTransactionBodyAutoBalance@.
   -> Api.TxBodyContent Api.S.BuildTx Api.S.BabbageEra
-  -- ^ The body content generted by @makeTransactionBodyAutoBalance@.
+  -- ^ The body content generated by @makeTransactionBodyAutoBalance@.
   -> Api.TxBody Api.S.BabbageEra
-  -- ^ The body generted by @makeTransactionBodyAutoBalance@.
+  -- ^ The body generated by @makeTransactionBodyAutoBalance@.
   -> Int
   -- ^ The number of skeleton outputs we don't want to touch.
   -> Either Api.S.TxBodyError (Api.TxBody Api.S.BabbageEra)

diff --git a/src/GeniusYield/Transaction/CoinSelection.hs b/src/GeniusYield/Transaction/CoinSelection.hs
@@ -112,19 +112,31 @@ selectInputs :: forall m v. MonadRandom m
              -> ExceptT BalancingError m ([GYTxInDetailed v], [GYTxOut v])
 selectInputs
     GYCoinSelectionEnv
-        { existingInputs
+        { existingInputs = existingInputs'
         , requiredOutputs
         , mintValue
         , changeAddr
         , ownUtxos
         , extraLovelace
         , minimumUTxOF
+        , adaSource
+        , adaSink
         }
     GYLegacy = do
+    additionalInputForReplayProtection <- except $
+          if existingInputs' == mempty then -- For replay protection, every transaction must spend at least one UTxO.
+            -- We pick the UTxO having most value.
+            let ownUtxosList = utxosToList ownUtxos
+            in case ownUtxosList of
+                [] -> Left BalancingErrorEmptyOwnUTxOs
+                _  -> pure . pure $ utxoAsPubKeyInp $ maximumBy (compare `on` utxoValue) ownUtxosList
+          else pure Nothing
     let
+        additionalInputForReplayProtectionAsList = maybe [] pure additionalInputForReplayProtection
+        existingInputs = additionalInputForReplayProtectionAsList <> existingInputs'
         valueIn, valueOut :: GYValue
-        valueIn         = foldMap gyTxInDetValue existingInputs
-        valueOut        = foldMap snd requiredOutputs
+        valueIn         = foldMap gyTxInDetValue existingInputs <> valueFromLovelace (fromIntegral adaSource)
+        valueOut        = foldMap snd requiredOutputs <> valueFromLovelace (fromIntegral adaSink)
         valueMissing    = missing (valueFromLovelace (fromIntegral extraLovelace) <> valueOut `valueMinus` (valueIn <> mintValue))
     (addIns, addVal) <- except $ selectInputsLegacy
         ownUtxos
@@ -136,7 +148,7 @@ selectInputs
             [adjustTxOut minimumUTxOF (GYTxOut changeAddr tokenChange Nothing Nothing)
             | not $ isEmptyValue tokenChange
             ]
-    pure (addIns, changeOuts)
+    pure (additionalInputForReplayProtectionAsList <> addIns, changeOuts)
   where
     missing :: GYValue -> Map GYAssetClass Natural
     missing v = foldl' f Map.empty $ valueToList v

diff --git a/src/GeniusYield/Types/TxCert.hs b/src/GeniusYield/Types/TxCert.hs
@@ -23,6 +23,12 @@ import           GeniusYield.Types.TxCert.Internal
 mkStakeAddressRegistrationCertificate :: GYStakeCredential -> GYTxCert v
 mkStakeAddressRegistrationCertificate sc = GYTxCert (GYStakeAddressRegistrationCertificate sc) Nothing
 
+{-| Note that deregistration certificate requires following preconditions:
+
+1. The stake address must be registered.
+
+2. The corresponding rewards balance is zero.
+-}
 mkStakeAddressDeregistrationCertificate :: GYStakeCredential -> GYTxCertWitness v -> GYTxCert v
 mkStakeAddressDeregistrationCertificate sc wit = GYTxCert (GYStakeAddressDeregistrationCertificate sc) (Just wit)
 

diff --git a/tests-privnet/GeniusYield/Test/Privnet/Stake.hs b/tests-privnet/GeniusYield/Test/Privnet/Stake.hs
@@ -0,0 +1,38 @@
+module GeniusYield.Test.Privnet.Stake (
+    tests,
+) where
+
+import           Data.Maybe                     (fromJust)
+import           GeniusYield.Imports
+import           GeniusYield.Test.Privnet.Ctx
+import           GeniusYield.Test.Privnet.Setup
+import           GeniusYield.TxBuilder          (mustHaveCertificate)
+import           GeniusYield.Types
+import           Test.Tasty                     (TestTree, testGroup)
+import           Test.Tasty.HUnit               (testCaseSteps)
+
+-- This will check if we are able to register a stake credential without it's signature.
+registerStakeCredentialSteps :: (String -> IO ()) -> Ctx -> IO User
+registerStakeCredentialSteps info ctx = do
+  newUser <- newTempUserCtx ctx (ctxUserF ctx) (valueFromLovelace 1_000_000_000) (CreateUserConfig {cucGenerateCollateral = False, cucGenerateStakeKey = True})
+  pp <- ctxGetParams ctx & gyGetProtocolParameters'
+  info $ "-- Protocol parameters --\n" <> show pp <> "\n-- x --\n"
+  txBodyReg <- ctxRunI ctx newUser $ do
+    return $ mustHaveCertificate (mkStakeAddressRegistrationCertificate (userStakePkh newUser & fromJust & GYStakeCredentialByKey))
+  info $ "-- Tx body --\n" <> show txBodyReg <> "\n-- x --\n"
+  void $ submitTx ctx newUser txBodyReg
+  pure newUser
+
+deregisterStakeCredentialSteps :: User -> (String -> IO ()) -> Ctx -> IO ()
+deregisterStakeCredentialSteps user@User{..} info ctx = do
+  txBodyDereg <- ctxRunI ctx user $ do
+    return $ mustHaveCertificate (mkStakeAddressDeregistrationCertificate (userStakePkh user & fromJust & GYStakeCredentialByKey) GYTxCertWitnessKey)
+  info $ "-- Tx body --\n" <> show txBodyDereg <> "\n-- x --\n"
+  void $ submitTx' ctx $ signGYTxBody txBodyDereg [GYSomeSigningKey userPaymentSKey, userStakeSKey & fromJust & GYSomeSigningKey]
+
+tests :: IO Setup -> TestTree
+tests setup = testGroup "stake"
+  [ testCaseSteps "able to deregister a registered stake credential" $ \info -> withSetup setup info $ \ctx -> do
+    newUser <- registerStakeCredentialSteps info ctx
+    deregisterStakeCredentialSteps newUser info ctx
+  ]
diff --git a/tests-privnet/atlas-privnet-tests.hs b/tests-privnet/atlas-privnet-tests.hs
@@ -20,6 +20,7 @@ import           GeniusYield.Types
 import           GeniusYield.Test.Privnet.Ctx
 import qualified GeniusYield.Test.Privnet.Examples
 import           GeniusYield.Test.Privnet.Setup
+import qualified GeniusYield.Test.Privnet.Stake
 
 main :: IO ()
 main = do
@@ -61,5 +62,7 @@ main = do
 
           , GeniusYield.Test.Privnet.Examples.tests setup
 
+          , GeniusYield.Test.Privnet.Stake.tests setup
+
           ]