feat: ✨ add support of stake validators

Related to #294

atlas-cardano.cabal

@@ -137,6 +137,7 @@ library
     GeniusYield.Types.TxMetadata.Internal
     GeniusYield.Types.TxOut
     GeniusYield.Types.TxOutRef
+    GeniusYield.Types.TxWdrl
     GeniusYield.Types.UTxO
     GeniusYield.Types.Value
     GeniusYield.Types.Wallet

src/GeniusYield/Transaction.hs

@@ -78,12 +78,14 @@ import           Cardano.Slotting.Time                 (SystemStart)
 import           Cardano.Ledger.Core                   (EraTx (sizeTxF))
 import           Control.Lens                          (view)
 import           Control.Monad.Random
+import           Data.Semigroup                        (Sum (..))
 import           GeniusYield.HTTP.Errors               (IsGYApiError)
 import           GeniusYield.Imports
 import           GeniusYield.Transaction.CBOR
 import           GeniusYield.Transaction.CoinSelection
 import           GeniusYield.Transaction.Common
 import           GeniusYield.Types
+import           GeniusYield.Types.TxWdrl
 
 -- | A container for various network parameters, and user wallet information, used by balancer.
 data GYBuildTxEnv = GYBuildTxEnv
@@ -152,16 +154,17 @@ buildUnsignedTxBody :: forall m v.
         -> [GYTxOut v]
         -> GYUTxOs  -- ^ reference inputs
         -> Maybe (GYValue, [(GYMintScript v, GYRedeemer)])  -- ^ minted values
+        -> [GYTxWdrl v]  -- ^ withdrawals
         -> Maybe GYSlot
         -> Maybe GYSlot
         -> Set GYPubKeyHash
         -> Maybe GYTxMetadata
         -> m (Either BuildTxException GYTxBody)
-buildUnsignedTxBody env cstrat insOld outsOld refIns mmint lb ub signers mbTxMetadata = buildTxLoop cstrat extraLovelaceStart
+buildUnsignedTxBody env cstrat insOld outsOld refIns mmint wdrls lb ub signers mbTxMetadata = buildTxLoop cstrat extraLovelaceStart
   where
 
     step :: GYCoinSelectionStrategy -> Natural -> m (Either BuildTxException ([GYTxInDetailed v], GYUTxOs, [GYTxOut v]))
-    step stepStrat = fmap (first BuildTxBalancingError) . balanceTxStep env mmint insOld outsOld stepStrat
+    step stepStrat = fmap (first BuildTxBalancingError) . balanceTxStep env mmint (getSum $ foldMap' (coerce . gyTxWdrlAmount) wdrls) insOld outsOld stepStrat
 
     buildTxLoop :: GYCoinSelectionStrategy -> Natural -> m (Either BuildTxException GYTxBody)
     buildTxLoop stepStrat n
@@ -211,6 +214,7 @@ buildUnsignedTxBody env cstrat insOld outsOld refIns mmint lb ub signers mbTxMet
                     , gybtxCollaterals   = collaterals
                     , gybtxOuts          = outs
                     , gybtxMint          = mmint
+                    , gybtxWdrls         = wdrls
                     , gybtxInvalidBefore = lb
                     , gybtxInvalidAfter  = ub
                     , gybtxSigners       = signers
@@ -236,6 +240,7 @@ the tx with 'finalizeGYBalancedTx'. If such is the case, 'balanceTxStep' should
 balanceTxStep :: (HasCallStack, MonadRandom m)
     => GYBuildTxEnv
     -> Maybe (GYValue, [(GYMintScript v, GYRedeemer)])  -- ^ minting
+    -> Natural                                          -- ^ total withdrawal
     -> [GYTxInDetailed v]                               -- ^ transaction inputs
     -> [GYTxOut v]                                      -- ^ transaction outputs
     -> GYCoinSelectionStrategy                          -- ^ Coin selection strategy to use
@@ -249,6 +254,7 @@ balanceTxStep
         , gyBTxEnvCollateral     = collateral
         }
     mmint
+    totalWithdrawal
     ins
     outs
     cstrat
@@ -278,6 +284,7 @@ balanceTxStep
                     , maxValueSize    = fromMaybe
                                             (error "protocolParamMaxValueSize missing from protocol params")
                                             $ Api.S.protocolParamMaxValueSize $ Api.S.unbundleProtocolParams pp
+                    , totalWithdrawal = totalWithdrawal
                     }
                 cstrat
             pure (ins ++ addIns, collaterals, adjustedOuts ++ changeOuts)
@@ -302,6 +309,7 @@ finalizeGYBalancedTx
         , gybtxCollaterals   = collaterals
         , gybtxOuts          = outs
         , gybtxMint          = mmint
+        , gybtxWdrls         = wdrls
         , gybtxInvalidBefore = lb
         , gybtxInvalidAfter  = ub
         , gybtxSigners       = signers
@@ -401,6 +409,9 @@ finalizeGYBalancedTx
         toMetaInEra gymd = let md = txMetadataToApi gymd in
           if md == mempty then Api.TxMetadataNone else Api.TxMetadataInEra Api.TxMetadataInBabbageEra md
 
+    wdrls' :: Api.TxWithdrawals Api.BuildTx Api.BabbageEra
+    wdrls' = if wdrls == mempty then Api.TxWithdrawalsNone else Api.TxWithdrawals Api.WithdrawalsInBabbageEra $ map txWdrlToApi wdrls
+
     body :: Api.TxBodyContent Api.BuildTx Api.BabbageEra
     body = Api.TxBodyContent
         ins'
@@ -415,7 +426,7 @@ finalizeGYBalancedTx
         Api.TxAuxScriptsNone
         extra
         (Api.BuildTxWith $ Just $ Api.S.unbundleProtocolParams pp)
-        Api.TxWithdrawalsNone
+        wdrls'
         Api.TxCertificatesNone
         Api.TxUpdateProposalNone
         mint

src/GeniusYield/Transaction/CoinSelection.hs

@@ -86,6 +86,8 @@ data GYCoinSelectionEnv v = GYCoinSelectionEnv
     -- ^ Extra lovelace to look for on top of outputs, mainly for fee and any remaining would be given as change output by @makeTransactionBodyAutoBalance@, thus amount remaining besides fees, should satisfy minimum ada requirement else we would have to increase `extraLovelace` parameter.
     , minimumUTxOF    :: GYTxOut v -> Natural
     , maxValueSize    :: Natural
+    , totalWithdrawal :: Natural
+    -- ^ Total lovelaces being withdrawn from reward accounts.
     }
 
 data GYCoinSelectionStrategy
@@ -156,6 +158,7 @@ selectInputs
         , extraLovelace
         , minimumUTxOF
         , maxValueSize
+        , totalWithdrawal
         }
     cstrat = do
         CBalance.SelectionResult
@@ -208,7 +211,7 @@ selectInputs
     selectionParams = CBalance.SelectionParams
             { assetsToMint                = toTokenMap mintedVal
             , assetsToBurn                = toTokenMap burnedVal
-            , extraCoinSource             = CWallet.Coin 0
+            , extraCoinSource             = CWallet.Coin totalWithdrawal
             , extraCoinSink               = CWallet.Coin 0
             , outputsToCover              = map (bimap toCWalletAddress toTokenBundle) requiredOutputs
             , utxoAvailable               = CWallet.fromIndexPair (ownUtxosIndex, existingInpsIndex)  -- `fromIndexPair` would actually make first element to be @ownUtxosIndex `UTxOIndex.difference` existingInpsIndex@.

src/GeniusYield/Transaction/Common.hs

@@ -16,12 +16,13 @@ module GeniusYield.Transaction.Common (
     adjustTxOut
 ) where
 
-import qualified Cardano.Api         as Api
-import qualified Cardano.Api.Shelley as Api.S
+import qualified Cardano.Api              as Api
+import qualified Cardano.Api.Shelley      as Api.S
 
 import           GeniusYield.Imports
 import           GeniusYield.Types
-import qualified Text.Printf         as Printf
+import           GeniusYield.Types.TxWdrl (GYTxWdrl)
+import qualified Text.Printf              as Printf
 
 {- | An *almost* finalized Tx.
 
@@ -33,6 +34,7 @@ data GYBalancedTx v = GYBalancedTx
     , gybtxCollaterals   :: !GYUTxOs
     , gybtxOuts          :: ![GYTxOut v]
     , gybtxMint          :: !(Maybe (GYValue, [(GYMintScript v, GYRedeemer)]))
+    , gybtxWdrls         :: ![GYTxWdrl v]
     , gybtxInvalidBefore :: !(Maybe GYSlot)
     , gybtxInvalidAfter  :: !(Maybe GYSlot)
     , gybtxSigners       :: !(Set GYPubKeyHash)

src/GeniusYield/TxBuilder/Class.hs

@@ -59,6 +59,7 @@ module GeniusYield.TxBuilder.Class
     , mustHaveOptionalOutput
     , mustHaveTxMetadata
     , mustMint
+    , mustHaveWithdrawal
     , mustBeSignedBy
     , isInvalidBefore
     , isInvalidAfter
@@ -88,6 +89,7 @@ import qualified PlutusLedgerApi.V1.Value     as Plutus (AssetClass)
 import           GeniusYield.Imports
 import           GeniusYield.TxBuilder.Errors
 import           GeniusYield.Types
+import           GeniusYield.Types.TxWdrl     (GYTxWdrl (..))
 
 -------------------------------------------------------------------------------
 -- Class
@@ -342,6 +344,7 @@ data GYTxSkeleton (v :: PlutusVersion) = GYTxSkeleton
     , gytxOuts          :: ![GYTxOut v]
     , gytxRefIns        :: !(GYTxSkeletonRefIns v)
     , gytxMint          :: !(Map (GYMintScript v) (Map GYTokenName Integer, GYRedeemer))
+    , gytxWdrls         :: ![GYTxWdrl v]
     , gytxSigs          :: !(Set GYPubKeyHash)
     , gytxInvalidBefore :: !(Maybe GYSlot)
     , gytxInvalidAfter  :: !(Maybe GYSlot)
@@ -374,6 +377,7 @@ emptyGYTxSkeleton = GYTxSkeleton
     , gytxOuts          = []
     , gytxRefIns        = GYTxSkeletonNoRefIns
     , gytxMint          = Map.empty
+    , gytxWdrls         = []
     , gytxSigs          = Set.empty
     , gytxInvalidBefore = Nothing
     , gytxInvalidAfter  = Nothing
@@ -386,6 +390,7 @@ instance Semigroup (GYTxSkeleton v) where
         , gytxOuts          = gytxOuts x ++ gytxOuts y
         , gytxRefIns        = gytxRefIns x <> gytxRefIns y
         , gytxMint          = combineMint (gytxMint x) (gytxMint y)
+        , gytxWdrls         = combineWdrls (gytxWdrls x) (gytxWdrls y)
         , gytxSigs          = Set.union (gytxSigs x) (gytxSigs y)
         , gytxInvalidBefore = combineInvalidBefore (gytxInvalidBefore x) (gytxInvalidBefore y)
         , gytxInvalidAfter  = combineInvalidAfter (gytxInvalidAfter x) (gytxInvalidAfter y)
@@ -396,6 +401,8 @@ instance Semigroup (GYTxSkeleton v) where
         combineIns u v = nubBy ((==) `on` gyTxInTxOutRef) (u ++ v)
         -- we cannot combine redeemers, so we just pick first.
         combineMint = Map.unionWith (\(amt, r) (amt', _r) -> (Map.unionWith (+) amt amt', r))
+        -- we keep only one withdrawal per stake address
+        combineWdrls u v = nubBy ((==) `on` gyTxWdrlStakeAddress) (u ++ v)
 
         combineInvalidBefore :: Maybe GYSlot -> Maybe GYSlot -> Maybe GYSlot
         combineInvalidBefore m        Nothing  = m
@@ -640,6 +647,9 @@ mustMint :: GYMintScript v -> GYRedeemer -> GYTokenName -> Integer -> GYTxSkelet
 mustMint _ _ _ 0  = mempty
 mustMint p r tn n = emptyGYTxSkeleton {gytxMint = Map.singleton p (Map.singleton tn n, r)}
 
+mustHaveWithdrawal :: GYTxWdrl v -> GYTxSkeleton v
+mustHaveWithdrawal w = emptyGYTxSkeleton {gytxWdrls = [w]}
+
 mustBeSignedBy :: CanSignTx a => a -> GYTxSkeleton v
 mustBeSignedBy pkh = emptyGYTxSkeleton {gytxSigs = Set.singleton $ toPubKeyHash pkh}
 

src/GeniusYield/TxBuilder/Common.hs

@@ -154,6 +154,7 @@ buildTxCore ss eh pp ps cstrat ownUtxoUpdateF addrs change reservedCollateral ac
                     gytxOuts
                     (utxosFromList refInsUtxos)
                     gytxMint'
+                    gytxWdrls
                     gytxInvalidBefore
                     gytxInvalidAfter
                     gytxSigs

src/GeniusYield/Types/Script.hs

@@ -75,11 +75,32 @@ module GeniusYield.Types.Script (
     mintingPolicyIdFromCurrencySymbol,
     mintingPolicyIdCurrencySymbol,
 
+    -- * StakeValidator
+    GYStakeValidator,
+    stakeValidatorVersion,
+    stakeValidatorVersionFromWitness,
+    stakeValidatorFromPlutus,
+    stakeValidatorFromSerialisedScript,
+    stakeValidatorToSerialisedScript,
+    stakeValidatorToApi,
+    stakeValidatorFromApi,
+    stakeValidatorToApiPlutusScriptWitness,
+
+    -- * Witness for stake validator
+    GYStakeValScript (..),
+    gyStakeValScriptToSerialisedScript,
+    gyStakeValScriptWitnessToApiPlutusSW,
+
+    -- ** File operations
+    writeStakeValidator,
+    readStakeValidator,
+
     -- * Script
     GYScript,
     scriptVersion,
     validatorToScript,
     mintingPolicyToScript,
+    stakeValidatorToScript,
     scriptToApi,
     scriptFromCBOR,
     scriptFromCBOR',
@@ -458,6 +479,96 @@ mintingPolicyIdFromText policyid = bimap customError mintingPolicyIdFromApi
   where
     customError err = "Invalid minting policy: " ++ show policyid ++ "; Reason: " ++ show err
 
+-------------------------------------------------------------------------------
+-- Stake validator
+-------------------------------------------------------------------------------
+
+newtype GYStakeValidator v = GYStakeValidator (GYScript v)
+  deriving stock (Eq, Ord, Show)
+
+deriving newtype instance GEq GYStakeValidator
+deriving newtype instance GCompare GYStakeValidator
+
+instance GShow GYStakeValidator where
+  gshowsPrec = showsPrec
+
+stakeValidatorVersion :: GYStakeValidator v -> SingPlutusVersion v
+stakeValidatorVersion = coerce scriptVersion
+
+stakeValidatorVersionFromWitness :: GYStakeValScript v -> PlutusVersion
+stakeValidatorVersionFromWitness (GYStakeValScript mp) = fromSingPlutusVersion $ stakeValidatorVersion mp
+stakeValidatorVersionFromWitness (GYStakeValReference _ s) = fromSingPlutusVersion $ stakeValidatorVersion $ coerce s
+
+stakeValidatorFromPlutus :: forall v. SingPlutusVersionI v => PlutusTx.CompiledCode (PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> ()) -> GYStakeValidator v
+stakeValidatorFromPlutus = coerce (scriptFromPlutus @v)
+
+stakeValidatorFromSerialisedScript :: forall v. SingPlutusVersionI v => Plutus.SerialisedScript -> GYStakeValidator v
+stakeValidatorFromSerialisedScript = coerce . scriptFromSerialisedScript
+
+stakeValidatorToSerialisedScript :: GYStakeValidator v -> Plutus.SerialisedScript
+stakeValidatorToSerialisedScript = coerce >>> scriptToSerialisedScript >>> coerce
+
+stakeValidatorToScript :: GYStakeValidator v -> GYScript v
+stakeValidatorToScript = coerce
+
+stakeValidatorToApi :: GYStakeValidator v -> Api.PlutusScript (PlutusVersionToApi v)
+stakeValidatorToApi = coerce scriptToApi
+
+stakeValidatorFromApi :: forall v. SingPlutusVersionI v => Api.PlutusScript (PlutusVersionToApi v) -> GYStakeValidator v
+stakeValidatorFromApi = coerce (scriptFromApi @v)
+
+stakeValidatorToApiPlutusScriptWitness
+    :: GYStakeValidator v
+    -> Api.ScriptRedeemer
+    -> Api.ExecutionUnits
+    -> Api.ScriptWitness Api.WitCtxStake Api.BabbageEra
+stakeValidatorToApiPlutusScriptWitness (GYStakeValidator s) =
+    scriptToApiPlutusScriptWitness s Api.NoScriptDatumForStake
+
+data GYStakeValScript (u :: PlutusVersion) where
+    -- | 'VersionIsGreaterOrEqual' restricts which version scripts can be used in this transaction.
+    GYStakeValScript    :: v `VersionIsGreaterOrEqual` u => GYStakeValidator v -> GYStakeValScript u
+
+    -- | Reference inputs can be only used in V2 transactions.
+    GYStakeValReference :: !GYTxOutRef -> !(GYScript 'PlutusV2) -> GYStakeValScript 'PlutusV2
+
+deriving instance Show (GYStakeValScript v)
+
+instance Eq (GYStakeValScript v) where
+    GYStakeValReference r s == GYStakeValReference r' s' = r == r' && s == s'
+    GYStakeValScript p == GYStakeValScript p'            = defaultEq p p'
+    _ == _                                               = False
+
+instance Ord (GYStakeValScript v) where
+    GYStakeValReference r s `compare` GYStakeValReference r' s' = compare r r' <> compare s s'
+    GYStakeValReference _ _ `compare` _ = LT
+    GYStakeValScript p `compare` GYStakeValScript p' = defaultCompare p p'
+    GYStakeValScript _ `compare` _ = GT
+
+gyStakeValScriptToSerialisedScript :: GYStakeValScript u -> Plutus.SerialisedScript
+gyStakeValScriptToSerialisedScript (GYStakeValScript mp) = coerce mp & scriptToSerialisedScript & coerce
+gyStakeValScriptToSerialisedScript (GYStakeValReference _ s) = scriptToSerialisedScript s & coerce
+
+gyStakeValScriptWitnessToApiPlutusSW
+  :: GYStakeValScript u
+  -> Api.S.ScriptRedeemer
+  -> Api.S.ExecutionUnits
+  -> Api.S.ScriptWitness Api.S.WitCtxStake Api.S.BabbageEra
+gyStakeValScriptWitnessToApiPlutusSW (GYStakeValScript p) = stakeValidatorToApiPlutusScriptWitness p
+gyStakeValScriptWitnessToApiPlutusSW (GYStakeValReference r s) =
+    referenceScriptToApiPlutusScriptWitness r s
+    Api.NoScriptDatumForStake
+
+-- | Writes a stake validator to a file.
+--
+writeStakeValidator :: FilePath -> GYStakeValidator v -> IO ()
+writeStakeValidator file = writeScriptCore "Stake Validator" file . coerce
+
+-- | Reads a stake validator from a file.
+--
+readStakeValidator :: SingPlutusVersionI v => FilePath -> IO (GYStakeValidator v)
+readStakeValidator = coerce readScript
+
 -------------------------------------------------------------------------------
 -- Script
 -------------------------------------------------------------------------------

src/GeniusYield/Types/TxMetadata.hs

@@ -32,7 +32,7 @@ import qualified Data.ByteString                       as BS
 import qualified Data.Map.Strict                       as Map
 import qualified Data.Text.Encoding                    as TE
 import           Data.Word                             (Word64)
-import           GeniusYield.Imports                   (Text, foldl')
+import           GeniusYield.Imports                   (Text)
 import           GeniusYield.Types.TxMetadata.Internal (GYTxMetadataValue (..),
                                                         txMetadataValueFromApi,
                                                         txMetadataValueToApi)