feat: improved api for stake validators, fixes to coin selection to r…

…equire for collateral in case of withdrawal/ceritificate script witness, improved privnet test now also including stake validator, modified api of `stakeAddressInfo` to now return `Nothing` in case key is not registered

Related to #294

atlas-cardano.cabal

@@ -236,6 +236,8 @@ library framework-onchain-plutustx
   import:          common, plutus-ghc-options
   hs-source-dirs:  src-plutustx
   exposed-modules:
+    GeniusYield.OnChain.AStakeValidator
+    GeniusYield.OnChain.AStakeValidator.Compiled
     GeniusYield.OnChain.Examples.ReadOracle
     GeniusYield.OnChain.Examples.ReadOracle.Compiled
     GeniusYield.OnChain.TestToken
@@ -313,11 +315,15 @@ test-suite atlas-privnet-tests
   ghc-options:    -threaded -rtsopts
   hs-source-dirs: tests-privnet
   main-is:        atlas-privnet-tests.hs
-  other-modules:  GeniusYield.Test.Privnet.Stake
+  other-modules:
+    GeniusYield.Test.Privnet.Stake
+    GeniusYield.Test.Privnet.Stake.Key
+    GeniusYield.Test.Privnet.Stake.Utils
+    GeniusYield.Test.Privnet.Stake.Validator
 
   -- Dependencies inherited from the library. No need to specify bounds.
   build-depends:
-    , atlas-cardano
+    , atlas-cardano:{atlas-cardano, framework-onchain-plutustx}
     , base
     , containers
     , tasty

src-plutustx/GeniusYield/OnChain/AStakeValidator.hs

@@ -0,0 +1,31 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-|
+Module      : GeniusYield.OnChain.AStakeValidator
+Copyright   : (c) 2023 GYELD GMBH
+License     : Apache 2.0
+Maintainer  : support@geniusyield.co
+Stability   : develop
+
+-}
+module GeniusYield.OnChain.AStakeValidator
+    ( mkAStakeValidator
+    ) where
+
+import           PlutusLedgerApi.V2
+import           PlutusTx.Prelude   as PlutusTx
+
+{-# INLINABLE mkAStakeValidator #-}
+mkAStakeValidator :: Address -> BuiltinData -> BuiltinData -> ()
+mkAStakeValidator addr _ ctx' = case scriptContextPurpose ctx of
+  Certifying _ -> ()
+  Rewarding _  -> if paidToAddress then () else error ()
+  _            -> error ()
+  where
+    ctx :: ScriptContext
+    ctx = unsafeFromBuiltinData ctx'
+
+    info :: TxInfo
+    info = scriptContextTxInfo ctx
+
+    paidToAddress :: Bool
+    paidToAddress = any (\o -> txOutAddress o == addr) $ txInfoOutputs info

src-plutustx/GeniusYield/OnChain/AStakeValidator/Compiled.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE DataKinds       #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-|
+Module      : GeniusYield.OnChain.AStakeValidator.Compiled
+Copyright   : (c) 2023 GYELD GMBH
+License     : Apache 2.0
+Maintainer  : support@geniusyield.co
+Stability   : develop
+
+-}
+module GeniusYield.OnChain.AStakeValidator.Compiled (
+    originalAStakeValidator,
+) where
+
+import           GeniusYield.OnChain.AStakeValidator
+import           PlutusCore.Version                  (plcVersion100)
+import qualified PlutusLedgerApi.V2
+import qualified PlutusTx
+
+originalAStakeValidator
+  :: PlutusLedgerApi.V2.Address
+  -> PlutusTx.CompiledCode (PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> ())
+originalAStakeValidator addr =
+    $$(PlutusTx.compile [|| mkAStakeValidator ||])
+    `PlutusTx.unsafeApplyCode` PlutusTx.liftCode plcVersion100 addr

src/GeniusYield/Providers/Blockfrost.hs

@@ -451,17 +451,19 @@ blockfrostLookupDatum p dh = do
 -- Account info
 -------------------------------------------------------------------------------
 
-blockfrostStakeAddressInfo :: Blockfrost.Project -> GYStakeAddress -> IO GYStakeAddressInfo
+blockfrostStakeAddressInfo :: Blockfrost.Project -> GYStakeAddress -> IO (Maybe GYStakeAddressInfo)
 blockfrostStakeAddressInfo p saddr = do
   Blockfrost.runBlockfrost p (Blockfrost.getAccount (Blockfrost.mkAddress $ stakeAddressToText saddr)) >>= handler
   where
     -- This particular error is fine.
-    handler (Left Blockfrost.BlockfrostNotFound) = pure $ GYStakeAddressInfo Nothing 0
+    handler (Left Blockfrost.BlockfrostNotFound) = pure Nothing
     handler other                                = handleBlockfrostError "Account" $ other <&> \accInfo ->
-      GYStakeAddressInfo
-        { gyStakeAddressInfoDelegatedPool = Blockfrost._accountInfoPoolId accInfo >>= stakePoolIdFromTextMaybe . Blockfrost.unPoolId
-        , gyStakeAddressInfoAvailableRewards = fromInteger $ lovelacesToInteger $ Blockfrost._accountInfoWithdrawableAmount accInfo
-        }
+        if Blockfrost._accountInfoActive accInfo then Just $
+            GYStakeAddressInfo
+                { gyStakeAddressInfoDelegatedPool = Blockfrost._accountInfoPoolId accInfo >>= stakePoolIdFromTextMaybe . Blockfrost.unPoolId
+                , gyStakeAddressInfoAvailableRewards = fromInteger $ lovelacesToInteger $ Blockfrost._accountInfoWithdrawableAmount accInfo
+                }
+        else Nothing
 
 -------------------------------------------------------------------------------
 -- Auxiliary functions

src/GeniusYield/Providers/Maestro.hs

@@ -542,14 +542,16 @@ maestroLookupDatum env dh = do
 -------------------------------------------------------------------------------
 
 -- | Returns the 'GYStakeAddressInfo' queried from Maestro.
-maestroStakeAddressInfo :: Maestro.MaestroEnv 'Maestro.V1 -> GYStakeAddress -> IO GYStakeAddressInfo
+maestroStakeAddressInfo :: Maestro.MaestroEnv 'Maestro.V1 -> GYStakeAddress -> IO (Maybe GYStakeAddressInfo)
 maestroStakeAddressInfo env saddr = do
   handler <=< try $ Maestro.getTimestampedData <$> Maestro.accountInfo env (coerce stakeAddressToText saddr)
   where
     -- This particular error is fine.
-    handler (Left Maestro.MaestroNotFound) = pure $ GYStakeAddressInfo Nothing 0
+    handler (Left Maestro.MaestroNotFound) = pure Nothing
     handler other = handleMaestroError "AccountInfo" $ other <&> \accInfo ->
-      GYStakeAddressInfo
-        { gyStakeAddressInfoDelegatedPool = Maestro.accountInfoDelegatedPool accInfo >>= stakePoolIdFromTextMaybe . coerce
-        , gyStakeAddressInfoAvailableRewards = fromIntegral $ Maestro.accountInfoRewardsAvailable accInfo
-        }
+      if Maestro.accountInfoRegistered accInfo then Just $
+        GYStakeAddressInfo
+          { gyStakeAddressInfoDelegatedPool = Maestro.accountInfoDelegatedPool accInfo >>= stakePoolIdFromTextMaybe . coerce
+          , gyStakeAddressInfoAvailableRewards = fromIntegral $ Maestro.accountInfoRewardsAvailable accInfo
+          }
+      else Nothing

src/GeniusYield/Providers/Node.hs

@@ -105,15 +105,17 @@ stakePools :: GYEra -> Api.LocalNodeConnectInfo Api.CardanoMode -> IO (Set.Set A
 stakePools GYAlonzo  info = queryAlonzoEra  info Api.QueryStakePools
 stakePools GYBabbage info = queryBabbageEra info Api.QueryStakePools
 
-nodeStakeAddressInfo :: Api.LocalNodeConnectInfo Api.CardanoMode -> GYStakeAddress -> IO GYStakeAddressInfo
+nodeStakeAddressInfo :: Api.LocalNodeConnectInfo Api.CardanoMode -> GYStakeAddress -> IO (Maybe GYStakeAddressInfo)
 nodeStakeAddressInfo info saddr = resolveStakeAddressInfoFromApi saddr <$> queryBabbageEra info (Api.QueryStakeAddresses (Set.singleton $ stakeCredentialToApi $ stakeAddressToCredential saddr) (Api.localNodeNetworkId info))
 
-resolveStakeAddressInfoFromApi :: GYStakeAddress -> (Map.Map Api.StakeAddress Api.Lovelace, Map.Map Api.StakeAddress Api.S.PoolId) -> GYStakeAddressInfo
+resolveStakeAddressInfoFromApi :: GYStakeAddress -> (Map.Map Api.StakeAddress Api.Lovelace, Map.Map Api.StakeAddress Api.S.PoolId) -> Maybe GYStakeAddressInfo
 resolveStakeAddressInfoFromApi (stakeAddressToApi -> stakeAddr) (rewards, delegations) =
-    GYStakeAddressInfo
+    if Map.member stakeAddr rewards
+    then Just $ GYStakeAddressInfo
         { gyStakeAddressInfoAvailableRewards = fromIntegral $ Map.findWithDefault 0 stakeAddr rewards
         , gyStakeAddressInfoDelegatedPool = stakePoolIdFromApi <$> Map.lookup stakeAddr delegations
         }
+    else Nothing
 
 systemStart :: Api.LocalNodeConnectInfo Api.CardanoMode -> IO SystemStart
 systemStart info = queryCardanoMode info Api.QuerySystemStart

src/GeniusYield/Transaction.hs

@@ -165,20 +165,8 @@ buildUnsignedTxBody :: forall m v.
         -> m (Either BuildTxException GYTxBody)
 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 adaSource adaSink insOld outsOld stepStrat
+    step stepStrat = fmap (first BuildTxBalancingError) . balanceTxStep env mmint wdrls certs insOld outsOld stepStrat
 
     buildTxLoop :: GYCoinSelectionStrategy -> Natural -> m (Either BuildTxException GYTxBody)
     buildTxLoop stepStrat n
@@ -255,8 +243,8 @@ the tx with 'finalizeGYBalancedTx'. If such is the case, 'balanceTxStep' should
 balanceTxStep :: (HasCallStack, MonadRandom m)
     => GYBuildTxEnv
     -> Maybe (GYValue, [(GYMintScript v, GYRedeemer)])  -- ^ minting
-    -> Natural                                          -- ^ ada source
-    -> Natural                                          -- ^ ada sink
+    -> [GYTxWdrl v]                                     -- ^ withdrawals
+    -> [GYTxCert v]                                     -- ^ certificates
     -> [GYTxInDetailed v]                               -- ^ transaction inputs
     -> [GYTxOut v]                                      -- ^ transaction outputs
     -> GYCoinSelectionStrategy                          -- ^ Coin selection strategy to use
@@ -270,14 +258,27 @@ balanceTxStep
         , gyBTxEnvCollateral     = collateral
         }
     mmint
-    adaSource
-    adaSink
+    wdrls
+    certs
     ins
     outs
     cstrat
     = let adjustedOuts = map (adjustTxOut (minimumUTxO pp)) outs
           valueMint       = maybe mempty fst mmint
-          needsCollateral = valueMint /= mempty || any (isScriptWitness . gyTxInWitness . gyTxInDet) ins
+          needsCollateral = valueMint /= mempty || any (isScriptWitness . gyTxInWitness . gyTxInDet) ins || any (isCertScriptWitness . gyTxCertWitness) certs || any (isWdrlScriptWitness . gyTxWdrlWitness) wdrls
+          unbundledPP = Api.S.unbundleProtocolParams pp
+          ppStakeAddressDeposit = Api.S.protocolParamStakeAddressDeposit unbundledPP
+          (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
           collaterals
             | needsCollateral = utxosFromUTxO collateral
             | otherwise       = mempty
@@ -300,7 +301,7 @@ balanceTxStep
                             . adjustTxOut (minimumUTxO pp)
                     , maxValueSize    = fromMaybe
                                             (error "protocolParamMaxValueSize missing from protocol params")
-                                            $ Api.S.protocolParamMaxValueSize $ Api.S.unbundleProtocolParams pp
+                                            $ Api.S.protocolParamMaxValueSize unbundledPP
                     , adaSource = adaSource
                     , adaSink   = adaSink
                     }
@@ -309,6 +310,10 @@ balanceTxStep
   where
     isScriptWitness GYTxInWitnessKey      = False
     isScriptWitness GYTxInWitnessScript{} = True
+    isCertScriptWitness (Just GYTxCertWitnessScript{}) = True
+    isCertScriptWitness _                              = False
+    isWdrlScriptWitness GYTxWdrlWitnessScript{} = True
+    isWdrlScriptWitness _                       = False
 
 retColSup :: Api.S.TxTotalAndReturnCollateralSupportedInEra Api.S.BabbageEra
 retColSup = Api.TxTotalAndReturnCollateralInBabbageEra

src/GeniusYield/TxBuilder/Class.hs

@@ -166,7 +166,8 @@ class MonadError GYTxMonadException m => GYTxQueryMonad m where
     utxosAtPaymentCredentialsWithDatums :: [GYPaymentCredential] -> m [(GYUTxO, Maybe GYDatum)]
     utxosAtPaymentCredentialsWithDatums = gyQueryUtxosAtPaymentCredsWithDatumsDefault utxosAtPaymentCredentials lookupDatum
 
-    stakeAddressInfo :: GYStakeAddress -> m GYStakeAddressInfo
+    -- | Obtain delegation information for a stake address. Note that in case stake address is not registered, this function should return `Nothing`.
+    stakeAddressInfo :: GYStakeAddress -> m (Maybe GYStakeAddressInfo)
 
     {- | Obtain the slot config for the network.
 

src/GeniusYield/TxBuilder/Run.hs

@@ -217,10 +217,14 @@ instance GYTxQueryMonad GYTxMonadRun where
     stakeAddressInfo saddr = do
         ms <- liftRun $ gets mockStake
         let sc = stakeAddressToCredential saddr & stakeCredentialToPlutus & Plutus.StakingHash
-        pure $ GYStakeAddressInfo {
-            gyStakeAddressInfoAvailableRewards = fromInteger $ fromMaybe 0 $ lookupReward sc ms,
-            gyStakeAddressInfoDelegatedPool = Map.toList (stake'pools ms) & find (\(_pid, scs) -> sc `elem` pool'stakes scs) >>= (fst >>> unPoolId >>> pubKeyHashFromPlutus >>> rightToMaybe) >>= (pubKeyHashToApi >>> Api.serialiseToRawBytesHexText >>> Text.encodeUtf8 >>> Api.deserialiseFromRawBytesHex (Api.AsHash Api.AsStakePoolKey) >>> rightToMaybe) <&> stakePoolIdFromApi
-        }
+            mscRewards = lookupReward sc ms
+        pure $ case mscRewards of
+            Nothing -> Nothing
+            Just r -> Just $
+              GYStakeAddressInfo {
+                  gyStakeAddressInfoAvailableRewards = fromInteger r,
+                  gyStakeAddressInfoDelegatedPool = Map.toList (stake'pools ms) & find (\(_pid, scs) -> sc `elem` pool'stakes scs) >>= (fst >>> unPoolId >>> pubKeyHashFromPlutus >>> rightToMaybe) >>= (pubKeyHashToApi >>> Api.serialiseToRawBytesHexText >>> Text.encodeUtf8 >>> Api.deserialiseFromRawBytesHex (Api.AsHash Api.AsStakePoolKey) >>> rightToMaybe) <&> stakePoolIdFromApi
+              }
 
     slotConfig = do
         (zero, len) <- slotConfig'

src/GeniusYield/Types/Credential.hs

@@ -32,7 +32,11 @@ import           GeniusYield.Types.PaymentKeyHash (GYPaymentKeyHash,
                                                    paymentKeyHashToApi,
                                                    paymentKeyHashToPlutus)
 import           GeniusYield.Types.PubKeyHash     (CanSignTx (fromPubKeyHash, toPubKeyHash))
-import           GeniusYield.Types.Script         (GYValidatorHash,
+import           GeniusYield.Types.Script         (GYStakeValidatorHash,
+                                                   GYValidatorHash,
+                                                   stakeValidatorHashFromApi,
+                                                   stakeValidatorHashToApi,
+                                                   stakeValidatorHashToPlutus,
                                                    validatorHashFromApi,
                                                    validatorHashToApi,
                                                    validatorHashToPlutus)
@@ -86,31 +90,31 @@ paymentCredentialToBech32 (GYPaymentCredentialByScript sh) = serialiseToBech32Wi
 -- | Stake credential.
 data GYStakeCredential
        = GYStakeCredentialByKey !GYStakeKeyHash
-       | GYStakeCredentialByScript !GYValidatorHash
+       | GYStakeCredentialByScript !GYStakeValidatorHash
     deriving (Show, Eq, Ord)
 
 instance Printf.PrintfArg GYStakeCredential where
   formatArg (GYStakeCredentialByKey skh) = Printf.formatArg $ "Stake key credential: " <> Api.serialiseToRawBytesHexText (stakeKeyHashToApi skh)
-  formatArg (GYStakeCredentialByScript sh) = Printf.formatArg $ "Stake script credential: " <> Api.serialiseToRawBytesHexText (validatorHashToApi sh)
+  formatArg (GYStakeCredentialByScript sh) = Printf.formatArg $ "Stake script credential: " <> Api.serialiseToRawBytesHexText (stakeValidatorHashToApi sh)
 
 -- | Convert @GY@ type to corresponding type in @cardano-api@ library.
 stakeCredentialToApi :: GYStakeCredential -> Api.StakeCredential
 stakeCredentialToApi (GYStakeCredentialByKey skh) = Api.StakeCredentialByKey (stakeKeyHashToApi skh)
-stakeCredentialToApi (GYStakeCredentialByScript sh) = Api.StakeCredentialByScript (validatorHashToApi sh)
+stakeCredentialToApi (GYStakeCredentialByScript sh) = Api.StakeCredentialByScript (stakeValidatorHashToApi sh)
 
 -- | Get @GY@ type from corresponding type in @cardano-api@ library.
 stakeCredentialFromApi :: Api.StakeCredential -> GYStakeCredential
 stakeCredentialFromApi (Api.StakeCredentialByKey skh) = GYStakeCredentialByKey (stakeKeyHashFromApi skh)
-stakeCredentialFromApi (Api.StakeCredentialByScript sh) = GYStakeCredentialByScript (validatorHashFromApi sh)
+stakeCredentialFromApi (Api.StakeCredentialByScript sh) = GYStakeCredentialByScript (stakeValidatorHashFromApi sh)
 
 -- | Convert @GY@ type to corresponding type in @plutus@ library.
 stakeCredentialToPlutus :: GYStakeCredential -> Plutus.Credential
 stakeCredentialToPlutus (GYStakeCredentialByKey pkh) = Plutus.PubKeyCredential (paymentKeyHashToPlutus $ fromPubKeyHash $ toPubKeyHash pkh)
-stakeCredentialToPlutus (GYStakeCredentialByScript sh) = Plutus.ScriptCredential (validatorHashToPlutus sh)
+stakeCredentialToPlutus (GYStakeCredentialByScript sh) = Plutus.ScriptCredential (stakeValidatorHashToPlutus sh)
 
 -- | Get hexadecimal value of stake credential.
 stakeCredentialToHexText :: GYStakeCredential -> Text
 stakeCredentialToHexText =
   \case
     GYStakeCredentialByKey skh -> Api.serialiseToRawBytesHexText (stakeKeyHashToApi skh)
-    GYStakeCredentialByScript sh -> Api.serialiseToRawBytesHexText (validatorHashToApi sh)
+    GYStakeCredentialByScript sh -> Api.serialiseToRawBytesHexText (stakeValidatorHashToApi sh)

src/GeniusYield/Types/Providers.hs

@@ -132,7 +132,7 @@ data GYProviders = GYProviders
     , gySlotActions         :: !GYSlotActions
     , gyGetParameters       :: !GYGetParameters
     , gyQueryUTxO           :: !GYQueryUTxO
-    , gyGetStakeAddressInfo :: !(GYStakeAddress -> IO GYStakeAddressInfo)
+    , gyGetStakeAddressInfo :: !(GYStakeAddress -> IO (Maybe GYStakeAddressInfo))
     , gyLog'                :: !GYLog
     }