feat: add support of certificates

Related to #294

atlas-cardano.cabal

@@ -110,6 +110,7 @@ library
     GeniusYield.Types
     GeniusYield.Types.Ada
     GeniusYield.Types.Address
+    GeniusYield.Types.Certificate
     GeniusYield.Types.Credential
     GeniusYield.Types.Datum
     GeniusYield.Types.Era
@@ -134,6 +135,8 @@ library
     GeniusYield.Types.Time
     GeniusYield.Types.Tx
     GeniusYield.Types.TxBody
+    GeniusYield.Types.TxCert
+    GeniusYield.Types.TxCert.Internal
     GeniusYield.Types.TxIn
     GeniusYield.Types.TxMetadata
     GeniusYield.Types.TxMetadata.Internal

src/GeniusYield/Transaction.hs

@@ -85,7 +85,7 @@ import           GeniusYield.Transaction.CBOR
 import           GeniusYield.Transaction.CoinSelection
 import           GeniusYield.Transaction.Common
 import           GeniusYield.Types
-import           GeniusYield.Types.TxWdrl
+import           GeniusYield.Types.TxCert.Internal
 
 -- | A container for various network parameters, and user wallet information, used by balancer.
 data GYBuildTxEnv = GYBuildTxEnv
@@ -155,16 +155,28 @@ buildUnsignedTxBody :: forall m v.
         -> GYUTxOs  -- ^ reference inputs
         -> Maybe (GYValue, [(GYMintScript v, GYRedeemer)])  -- ^ minted values
         -> [GYTxWdrl v]  -- ^ withdrawals
+        -> [GYTxCert v]  -- ^ certificates
         -> Maybe GYSlot
         -> Maybe GYSlot
         -> Set GYPubKeyHash
         -> Maybe GYTxMetadata
         -> m (Either BuildTxException GYTxBody)
-buildUnsignedTxBody env cstrat insOld outsOld refIns mmint wdrls lb ub signers mbTxMetadata = buildTxLoop cstrat extraLovelaceStart
+buildUnsignedTxBody env cstrat insOld outsOld refIns mmint wdrls certs lb ub signers mbTxMetadata = buildTxLoop cstrat extraLovelaceStart
   where
-
+    ppStakeAddressDeposit = Api.S.protocolParamStakeAddressDeposit $ Api.S.unbundleProtocolParams $ gyBTxEnvProtocolParams env
+    (stakeCredDeregsAmt :: Natural, stakeCredRegsAmt :: Natural) = foldl' (\acc@(!accDeregs, !accRegs) (gyTxCertCertificate -> cert) -> case cert of
+            GYStakeAddressDeregistrationCertificate _ -> (accDeregs + 1, accRegs)
+            GYStakeAddressRegistrationCertificate _   -> (accDeregs, accRegs + 1)
+            _                                         -> acc) (0, 0) certs
+    -- Extra ada is received from withdrawals and stake credential deregistration.
+    adaSource =
+      let wdrlsAda = getSum $ foldMap' (coerce . gyTxWdrlAmount) wdrls
+          stakeCredDeregsAda = stakeCredDeregsAmt * fromIntegral ppStakeAddressDeposit
+      in wdrlsAda + stakeCredDeregsAda
+    -- Ada lost due to stake credential registration.
+    adaSink = stakeCredRegsAmt * fromIntegral ppStakeAddressDeposit
     step :: GYCoinSelectionStrategy -> Natural -> m (Either BuildTxException ([GYTxInDetailed v], GYUTxOs, [GYTxOut v]))
-    step stepStrat = fmap (first BuildTxBalancingError) . balanceTxStep env mmint (getSum $ foldMap' (coerce . gyTxWdrlAmount) wdrls) insOld outsOld stepStrat
+    step stepStrat = fmap (first BuildTxBalancingError) . balanceTxStep env mmint adaSource adaSink insOld outsOld stepStrat
 
     buildTxLoop :: GYCoinSelectionStrategy -> Natural -> m (Either BuildTxException GYTxBody)
     buildTxLoop stepStrat n
@@ -215,6 +227,7 @@ buildUnsignedTxBody env cstrat insOld outsOld refIns mmint wdrls lb ub signers m
                     , gybtxOuts          = outs
                     , gybtxMint          = mmint
                     , gybtxWdrls         = wdrls
+                    , gybtxCerts         = certs
                     , gybtxInvalidBefore = lb
                     , gybtxInvalidAfter  = ub
                     , gybtxSigners       = signers
@@ -240,7 +253,8 @@ 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
+    -> Natural                                          -- ^ ada source
+    -> Natural                                          -- ^ ada sink
     -> [GYTxInDetailed v]                               -- ^ transaction inputs
     -> [GYTxOut v]                                      -- ^ transaction outputs
     -> GYCoinSelectionStrategy                          -- ^ Coin selection strategy to use
@@ -254,7 +268,8 @@ balanceTxStep
         , gyBTxEnvCollateral     = collateral
         }
     mmint
-    totalWithdrawal
+    adaSource
+    adaSink
     ins
     outs
     cstrat
@@ -284,7 +299,8 @@ balanceTxStep
                     , maxValueSize    = fromMaybe
                                             (error "protocolParamMaxValueSize missing from protocol params")
                                             $ Api.S.protocolParamMaxValueSize $ Api.S.unbundleProtocolParams pp
-                    , totalWithdrawal = totalWithdrawal
+                    , adaSource = adaSource
+                    , adaSink   = adaSink
                     }
                 cstrat
             pure (ins ++ addIns, collaterals, adjustedOuts ++ changeOuts)
@@ -310,6 +326,7 @@ finalizeGYBalancedTx
         , gybtxOuts          = outs
         , gybtxMint          = mmint
         , gybtxWdrls         = wdrls
+        , gybtxCerts         = certs
         , gybtxInvalidBefore = lb
         , gybtxInvalidAfter  = ub
         , gybtxSigners       = signers
@@ -412,6 +429,19 @@ finalizeGYBalancedTx
     wdrls' :: Api.TxWithdrawals Api.BuildTx Api.BabbageEra
     wdrls' = if wdrls == mempty then Api.TxWithdrawalsNone else Api.TxWithdrawals Api.WithdrawalsInBabbageEra $ map txWdrlToApi wdrls
 
+    certs' =
+      if certs == mempty
+        then Api.TxCertificatesNone
+        else
+          let apiCertsFromGY =
+                foldl'
+                  (\(accCerts, accWits) cert ->
+                    let (apiCert, mapiWit) = txCertToApi cert
+                        apiWit = maybe Map.empty (uncurry Map.singleton) mapiWit
+                    in (apiCert : accCerts, accWits <> apiWit)
+                  ) (mempty, mempty) certs
+          in Api.TxCertificates Api.S.CertificatesInBabbageEra (reverse $ fst apiCertsFromGY) $ Api.BuildTxWith (snd apiCertsFromGY)
+
     body :: Api.TxBodyContent Api.BuildTx Api.BabbageEra
     body = Api.TxBodyContent
         ins'
@@ -427,7 +457,7 @@ finalizeGYBalancedTx
         extra
         (Api.BuildTxWith $ Just $ Api.S.unbundleProtocolParams pp)
         wdrls'
-        Api.TxCertificatesNone
+        certs'
         Api.TxUpdateProposalNone
         mint
         Api.TxScriptValidityNone

src/GeniusYield/Transaction/CoinSelection.hs

@@ -86,8 +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.
+    , adaSource       :: Natural
+    , adaSink         :: Natural
     }
 
 data GYCoinSelectionStrategy
@@ -158,7 +158,8 @@ selectInputs
         , extraLovelace
         , minimumUTxOF
         , maxValueSize
-        , totalWithdrawal
+        , adaSource
+        , adaSink
         }
     cstrat = do
         CBalance.SelectionResult
@@ -211,8 +212,8 @@ selectInputs
     selectionParams = CBalance.SelectionParams
             { assetsToMint                = toTokenMap mintedVal
             , assetsToBurn                = toTokenMap burnedVal
-            , extraCoinSource             = CWallet.Coin totalWithdrawal
-            , extraCoinSink               = CWallet.Coin 0
+            , extraCoinSource             = CWallet.Coin adaSource
+            , extraCoinSink               = CWallet.Coin adaSink
             , outputsToCover              = map (bimap toCWalletAddress toTokenBundle) requiredOutputs
             , utxoAvailable               = CWallet.fromIndexPair (ownUtxosIndex, existingInpsIndex)  -- `fromIndexPair` would actually make first element to be @ownUtxosIndex `UTxOIndex.difference` existingInpsIndex@.
             , selectionStrategy           = case cstrat of

src/GeniusYield/Transaction/Common.hs

@@ -16,13 +16,12 @@ 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           GeniusYield.Types.TxWdrl (GYTxWdrl)
-import qualified Text.Printf              as Printf
+import qualified Text.Printf         as Printf
 
 {- | An *almost* finalized Tx.
 
@@ -35,6 +34,7 @@ data GYBalancedTx v = GYBalancedTx
     , gybtxOuts          :: ![GYTxOut v]
     , gybtxMint          :: !(Maybe (GYValue, [(GYMintScript v, GYRedeemer)]))
     , gybtxWdrls         :: ![GYTxWdrl v]
+    , gybtxCerts         :: ![GYTxCert v]
     , gybtxInvalidBefore :: !(Maybe GYSlot)
     , gybtxInvalidAfter  :: !(Maybe GYSlot)
     , gybtxSigners       :: !(Set GYPubKeyHash)

src/GeniusYield/TxBuilder/Class.hs

@@ -60,6 +60,7 @@ module GeniusYield.TxBuilder.Class
     , mustHaveTxMetadata
     , mustMint
     , mustHaveWithdrawal
+    , mustHaveCertificate
     , mustBeSignedBy
     , isInvalidBefore
     , isInvalidAfter
@@ -89,7 +90,6 @@ import qualified PlutusLedgerApi.V1.Value     as Plutus (AssetClass)
 import           GeniusYield.Imports
 import           GeniusYield.TxBuilder.Errors
 import           GeniusYield.Types
-import           GeniusYield.Types.TxWdrl     (GYTxWdrl (..))
 
 -------------------------------------------------------------------------------
 -- Class
@@ -351,6 +351,7 @@ data GYTxSkeleton (v :: PlutusVersion) = GYTxSkeleton
     , gytxMint          :: !(Map (GYMintScript v) (Map GYTokenName Integer, GYRedeemer))
     , gytxWdrls         :: ![GYTxWdrl v]
     , gytxSigs          :: !(Set GYPubKeyHash)
+    , gytxCerts         :: ![GYTxCert v]
     , gytxInvalidBefore :: !(Maybe GYSlot)
     , gytxInvalidAfter  :: !(Maybe GYSlot)
     , gytxMetadata      :: !(Maybe GYTxMetadata)
@@ -384,6 +385,7 @@ emptyGYTxSkeleton = GYTxSkeleton
     , gytxMint          = Map.empty
     , gytxWdrls         = []
     , gytxSigs          = Set.empty
+    , gytxCerts         = []
     , gytxInvalidBefore = Nothing
     , gytxInvalidAfter  = Nothing
     , gytxMetadata      = Nothing
@@ -397,6 +399,7 @@ instance Semigroup (GYTxSkeleton v) where
         , gytxMint          = combineMint (gytxMint x) (gytxMint y)
         , gytxWdrls         = combineWdrls (gytxWdrls x) (gytxWdrls y)
         , gytxSigs          = Set.union (gytxSigs x) (gytxSigs y)
+        , gytxCerts         = gytxCerts x <> gytxCerts y
         , gytxInvalidBefore = combineInvalidBefore (gytxInvalidBefore x) (gytxInvalidBefore y)
         , gytxInvalidAfter  = combineInvalidAfter (gytxInvalidAfter x) (gytxInvalidAfter y)
         , gytxMetadata      = gytxMetadata x <> gytxMetadata y
@@ -653,7 +656,10 @@ 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]}
+mustHaveWithdrawal w = mempty {gytxWdrls = [w]}
+
+mustHaveCertificate :: GYTxCert v -> GYTxSkeleton v
+mustHaveCertificate c = mempty {gytxCerts = [c]}
 
 mustBeSignedBy :: CanSignTx a => a -> GYTxSkeleton v
 mustBeSignedBy pkh = emptyGYTxSkeleton {gytxSigs = Set.singleton $ toPubKeyHash pkh}

src/GeniusYield/TxBuilder/Common.hs

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

src/GeniusYield/Types.hs

@@ -15,6 +15,7 @@ import           Numeric.Natural                    (Natural)
 
 import           GeniusYield.Types.Ada              as X
 import           GeniusYield.Types.Address          as X
+import           GeniusYield.Types.Certificate      as X
 import           GeniusYield.Types.Credential       as X
 import           GeniusYield.Types.Datum            as X
 import           GeniusYield.Types.Era              as X
@@ -38,10 +39,12 @@ import           GeniusYield.Types.StakePoolId      as X
 import           GeniusYield.Types.Time             as X
 import           GeniusYield.Types.Tx               as X
 import           GeniusYield.Types.TxBody           as X
+import           GeniusYield.Types.TxCert           as X
 import           GeniusYield.Types.TxIn             as X
 import           GeniusYield.Types.TxMetadata       as X
 import           GeniusYield.Types.TxOut            as X
 import           GeniusYield.Types.TxOutRef         as X
+import           GeniusYield.Types.TxWdrl           as X
 import           GeniusYield.Types.UTxO             as X
 import           GeniusYield.Types.Value            as X
 import           GeniusYield.Types.Wallet           as X

src/GeniusYield/Types/Certificate.hs

@@ -0,0 +1,51 @@
+{-|
+Module      : GeniusYield.Types.Certificate
+Copyright   : (c) 2023 GYELD GMBH
+License     : Apache 2.0
+Maintainer  : support@geniusyield.co
+Stability   : develop
+
+-}
+module GeniusYield.Types.Certificate (
+  GYCertificate (..),
+  certificateToApi,
+  certificateFromApiMaybe,
+  certificateToStakeCredential,
+) where
+
+import qualified Cardano.Api                   as Api
+import           GeniusYield.Types.Credential  (GYStakeCredential,
+                                                stakeCredentialFromApi,
+                                                stakeCredentialToApi)
+import           GeniusYield.Types.StakePoolId
+
+data GYCertificate =
+    GYStakeAddressRegistrationCertificate !GYStakeCredential
+  | GYStakeAddressDeregistrationCertificate !GYStakeCredential
+  | GYStakeAddressPoolDelegationCertificate !GYStakeCredential !GYStakePoolId
+  deriving stock (Eq, Show)
+
+certificateToApi :: GYCertificate -> Api.Certificate
+certificateToApi = \case
+  GYStakeAddressRegistrationCertificate sc -> Api.StakeAddressRegistrationCertificate (f sc)
+  GYStakeAddressDeregistrationCertificate sc -> Api.StakeAddressDeregistrationCertificate (f sc)
+  GYStakeAddressPoolDelegationCertificate sc spId -> Api.StakeAddressPoolDelegationCertificate (f sc) (g spId)
+  where
+    f = stakeCredentialToApi
+    g = stakePoolIdToApi
+
+certificateFromApiMaybe :: Api.Certificate -> Maybe GYCertificate
+certificateFromApiMaybe = \case
+  Api.StakeAddressRegistrationCertificate sc -> Just $ GYStakeAddressRegistrationCertificate (f sc)
+  Api.StakeAddressDeregistrationCertificate sc -> Just $ GYStakeAddressDeregistrationCertificate (f sc)
+  Api.StakeAddressPoolDelegationCertificate sc spId -> Just $ GYStakeAddressPoolDelegationCertificate (f sc) (g spId)
+  _ -> Nothing
+  where
+    f = stakeCredentialFromApi
+    g = stakePoolIdFromApi
+
+certificateToStakeCredential :: GYCertificate -> GYStakeCredential
+certificateToStakeCredential = \case
+  GYStakeAddressRegistrationCertificate sc -> sc
+  GYStakeAddressDeregistrationCertificate sc -> sc
+  GYStakeAddressPoolDelegationCertificate sc _ -> sc

src/GeniusYield/Types/StakePoolId.hs

@@ -18,17 +18,16 @@ module GeniusYield.Types.StakePoolId (
   stakePoolIdToBech32
 ) where
 
-import           Control.Lens                 ((?~))
-import           GeniusYield.Imports
-
 import qualified Cardano.Api                  as Api
 import qualified Cardano.Api.Shelley          as Api
+import           Control.Lens                 ((?~))
 import qualified Data.Aeson.Types             as Aeson
 import qualified Data.Csv                     as Csv
 import qualified Data.Swagger                 as Swagger
 import qualified Data.Swagger.Internal.Schema as Swagger
 import qualified Data.Text                    as Text
 import qualified Data.Text.Encoding           as Text
+import           GeniusYield.Imports
 import qualified Text.Printf                  as Printf
 import qualified Web.HttpApiData              as Web
 

src/GeniusYield/Types/TxCert.hs

@@ -0,0 +1,30 @@
+{-|
+Module      : GeniusYield.Types.TxCert
+Copyright   : (c) 2023 GYELD GMBH
+License     : Apache 2.0
+Maintainer  : support@geniusyield.co
+Stability   : develop
+
+-}
+module GeniusYield.Types.TxCert (
+    GYTxCert,
+    GYTxCertWitness (..),
+    txCertToApi,
+    mkStakeAddressRegistrationCertificate,
+    mkStakeAddressDeregistrationCertificate,
+    mkStakeAddressPoolDelegationCertificate,
+) where
+
+import           GeniusYield.Types.Certificate
+import           GeniusYield.Types.Credential      (GYStakeCredential)
+import           GeniusYield.Types.StakePoolId
+import           GeniusYield.Types.TxCert.Internal
+
+mkStakeAddressRegistrationCertificate :: GYStakeCredential -> GYTxCert v
+mkStakeAddressRegistrationCertificate sc = GYTxCert (GYStakeAddressRegistrationCertificate sc) Nothing
+
+mkStakeAddressDeregistrationCertificate :: GYStakeCredential -> GYTxCertWitness v -> GYTxCert v
+mkStakeAddressDeregistrationCertificate sc wit = GYTxCert (GYStakeAddressDeregistrationCertificate sc) (Just wit)
+
+mkStakeAddressPoolDelegationCertificate :: GYStakeCredential -> GYStakePoolId -> GYTxCertWitness v -> GYTxCert v
+mkStakeAddressPoolDelegationCertificate sc spId wit = GYTxCert (GYStakeAddressPoolDelegationCertificate sc spId) (Just wit)