Skip to content

Commit

Permalink
WIP
Browse files Browse the repository at this point in the history
  • Loading branch information
Jimbo4350 committed Mar 28, 2024
1 parent 1817630 commit 1b9cbaa
Show file tree
Hide file tree
Showing 4 changed files with 63 additions and 35 deletions.
4 changes: 2 additions & 2 deletions cabal.project
Original file line number Diff line number Diff line change
Expand Up @@ -31,8 +31,8 @@ packages:
trace-resources
trace-forward

program-options
ghc-options: -Werror
-- program-options
-- ghc-options: -Werror

test-show-details: direct

Expand Down
56 changes: 33 additions & 23 deletions cardano-testnet/src/Testnet/Components/SPO.hs
Original file line number Diff line number Diff line change
Expand Up @@ -3,6 +3,7 @@
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}


module Testnet.Components.SPO
Expand All @@ -15,17 +16,14 @@ module Testnet.Components.SPO
, registerSingleSpo
) where

import qualified Cardano.Api.Ledger as L
import Cardano.Api.Shelley hiding (cardanoEra)

import qualified Cardano.Ledger.Api.State.Query as L
import qualified Cardano.Ledger.Coin as L
import qualified Cardano.Ledger.Credential as L
import qualified Cardano.Ledger.Keys as L
import qualified Cardano.Ledger.Shelley.LedgerState as L

import Control.Monad
import Control.Monad.Catch (MonadCatch)
import Control.Monad.State.Strict (StateT)
import Control.Monad.State.Strict as StateT
import qualified Data.Aeson as Aeson
import Data.Map.Strict (Map)
Expand All @@ -45,7 +43,7 @@ import Testnet.Property.Utils
import Testnet.Start.Types

import Hedgehog
import Hedgehog.Extras (ExecConfig, threadDelay)
import Hedgehog.Extras (ExecConfig)
import qualified Hedgehog.Extras.Test.Base as H
import qualified Hedgehog.Extras.Test.File as H

Expand Down Expand Up @@ -89,7 +87,7 @@ checkStakeKeyRegistered
=> TmpAbsolutePath
-> NodeConfigFile 'In
-> SocketPath
-> EpochNo
-> EpochNo -- ^ Termination epoch
-> ExecConfig
-> String -- ^ Stake address
-> FilePath -- ^ Output file path of stake address info
Expand All @@ -112,7 +110,6 @@ checkStakeKeyRegistered tempAbsP nodeConfigFile sPath terminationEpoch execConfi
case result of
Right (_, dag) -> return dag
Left e -> do

void $ execCli' execConfig
[ "query", "stake-address-info"
, "--address", stakeAddr
Expand All @@ -130,20 +127,31 @@ checkStakeKeyRegistered tempAbsP nodeConfigFile sPath terminationEpoch execConfi
, "foldEpochStateError: " <> show e
]
where
handler :: StakeAddress -> AnyNewEpochState -> StateT DelegationsAndRewards IO LedgerStateCondition
handler (StakeAddress _ sCred) (AnyNewEpochState sbe newEpochState) =
handler :: StakeAddress -> AnyNewEpochState -> SlotNo -> BlockNo -> StateT DelegationsAndRewards IO LedgerStateCondition
handler (StakeAddress network sCred) (AnyNewEpochState sbe newEpochState) _ _ =
let umap = shelleyBasedEraConstraints sbe $ newEpochState ^. L.nesEsL . L.epochStateUMapL
dag@(registeredStakeCredentials, _) = L.filterStakePoolDelegsAndRewards umap $ Set.singleton sCred
delegsAndRewards = toDelegationsAndRewards dag
delegsAndRewards = shelleyBasedEraConstraints sbe $ toDelegationsAndRewards network sbe dag
in case Map.lookup sCred registeredStakeCredentials of
Nothing -> return ConditionNotMet
Just _ -> StateT.put delegsAndRewards >> return ConditionMet

toDelegationsAndRewards
:: (Map (L.Credential L.Staking c) (L.KeyHash L.StakePool c), Map (L.Credential 'L.Staking c) L.Coin)
:: L.EraCrypto (ShelleyLedgerEra era) ~ L.StandardCrypto
=> L.Network
-> ShelleyBasedEra era
-> (Map (L.Credential L.Staking (L.EraCrypto (ShelleyLedgerEra era))) (L.KeyHash L.StakePool (L.EraCrypto (ShelleyLedgerEra era))), Map (L.Credential 'L.Staking (L.EraCrypto (ShelleyLedgerEra era))) L.Coin)
-> DelegationsAndRewards
toDelegationsAndRewards = error "TODO"
toDelegationsAndRewards n _ (delegationMap, rewardsMap) =
let apiDelegationMap = Map.map toApiPoolId $ Map.mapKeys (toApiStakeAddress n) delegationMap
apiRewardsMap = Map.mapKeys (toApiStakeAddress n) rewardsMap
in DelegationsAndRewards (apiRewardsMap, apiDelegationMap)

toApiStakeAddress :: L.Network -> L.Credential 'L.Staking L.StandardCrypto -> StakeAddress
toApiStakeAddress = StakeAddress

toApiPoolId :: L.KeyHash L.StakePool L.StandardCrypto -> PoolId
toApiPoolId = StakePoolKeyHash

createStakeDelegationCertificate
:: (MonadTest m, MonadCatch m, MonadIO m, HasCallStack)
Expand Down Expand Up @@ -213,6 +221,9 @@ registerSingleSpo
:: (MonadTest m, MonadCatch m, MonadIO m, HasCallStack)
=> Int -- ^ Identifier for stake pool
-> TmpAbsolutePath
-> NodeConfigFile 'In
-> SocketPath
-> EpochNo -- ^ Termination epoch
-> CardanoTestnetOptions
-> ExecConfig
-> (TxIn, FilePath, String)
Expand All @@ -227,7 +238,7 @@ registerSingleSpo
-- 3. FilePath: Stake pool cold verification key
-- 4. FilePath: Stake pool VRF signing key
-- 5. FilePath: Stake pool VRF verification key
registerSingleSpo identifier tap@(TmpAbsolutePath tempAbsPath') cTestnetOptions execConfig
registerSingleSpo identifier tap@(TmpAbsolutePath tempAbsPath') nodeConfigFile socketPath termEpoch cTestnetOptions execConfig
(fundingInput, fundingSigninKey, changeAddr) = GHC.withFrozenCallStack $ do
let testnetMag = cardanoTestnetMagic cTestnetOptions
eraFlag= convertToEraFlag $ cardanoNodeEra cTestnetOptions
Expand Down Expand Up @@ -348,18 +359,17 @@ registerSingleSpo identifier tap@(TmpAbsolutePath tempAbsPath') cTestnetOptions
]
-- TODO: Currently we can't propagate the error message thrown by checkStakeKeyRegistered when using byDurationM
-- Instead we wait 15 seconds
threadDelay 15_000000

-- Check the pledger/owner stake key was registered
delegsAndRewards <-
checkStakeKeyRegistered
undefined
undefined
undefined
undefined
tap
execConfig
poolownerstakeaddr
("spo-"<> show identifier <> "-requirements" </> "pledger.stake.info")
checkStakeKeyRegistered
tap
nodeConfigFile
socketPath
termEpoch
execConfig
poolownerstakeaddr
("spo-"<> show identifier <> "-requirements" </> "pledger.stake.info")

(pledgerSAddr, _rewards, _poolId) <- H.headM $ mergeDelegsAndRewards delegsAndRewards

Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -47,7 +47,6 @@ import Testnet.Runtime

import Hedgehog (Property, (===))
import qualified Hedgehog as H
import Hedgehog.Extras (threadDelay)
import qualified Hedgehog.Extras.Stock.IO.Network.Sprocket as IO
import qualified Hedgehog.Extras.Test.Base as H
import qualified Hedgehog.Extras.Test.File as H
Expand Down Expand Up @@ -92,9 +91,17 @@ hprop_leadershipSchedule = H.integrationRetryWorkspace 2 "babbage-leadership-sch
utxo1Json <- H.leftFailM . H.readJsonFile $ work </> "utxo-1.json"
UTxO utxo1 <- H.noteShowM $ decodeEraUTxO sbe utxo1Json
txin1 <- H.noteShow =<< H.headM (Map.keys utxo1)

let node1SocketPath = Api.File $ IO.sprocketSystemName node1sprocket
nodeConfigFile = Api.File configurationFile
termEpoch = 15
(stakePoolIdNewSpo, stakePoolColdSigningKey, stakePoolColdVKey, vrfSkey, _)
<- registerSingleSpo 1 tempAbsPath cTestnetOptions execConfig (txin1, utxoSKeyFile, utxoAddr)
<- registerSingleSpo 1 tempAbsPath
(Api.File configurationFile)
node1SocketPath
10
cTestnetOptions
execConfig
(txin1, utxoSKeyFile, utxoAddr)

-- Create test stake address to delegate to the new stake pool
-- NB: We need to fund the payment credential of the overall address
Expand Down Expand Up @@ -193,14 +200,14 @@ hprop_leadershipSchedule = H.integrationRetryWorkspace 2 "babbage-leadership-sch
, "--tx-file", delegRegTestDelegatorTxFp
]

-- TODO: Can be removed if checkStakeKeyRegistered uses foldEpochState
threadDelay 15_000000

-------------------------------------------------------------------

let testDelegatorStakeAddressInfoOutFp = work </> "test-delegator-stake-address-info.json"
void $ checkStakeKeyRegistered
tempAbsPath
nodeConfigFile
node1SocketPath
termEpoch
execConfig
testDelegatorStakeAddress
testDelegatorStakeAddressInfoOutFp
Expand Down Expand Up @@ -257,7 +264,7 @@ hprop_leadershipSchedule = H.integrationRetryWorkspace 2 "babbage-leadership-sch

-- Wait for 2 epochs to pass
void $ waitUntilEpoch (Api.File configurationFile)
(Api.File $ IO.sprocketSystemName node1sprocket) (EpochNo 3)
node1SocketPath (EpochNo 3)

currentLeaderShipScheduleFile <- H.noteTempFile work "current-schedule.log"

Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -42,6 +42,7 @@ import Hedgehog (Property)
import qualified Hedgehog as H
import Hedgehog.Extras (threadDelay)
import Hedgehog.Extras.Stock (sprocketSystemName)
import qualified Hedgehog.Extras.Stock.IO.Network.Sprocket as IO
import qualified Hedgehog.Extras.Test.Base as H
import qualified Hedgehog.Extras.Test.File as H

Expand Down Expand Up @@ -85,8 +86,17 @@ hprop_kes_period_info = H.integrationRetryWorkspace 2 "kes-period-info" $ \tempA
UTxO utxo1 <- H.noteShowM $ decodeEraUTxO sbe utxo1Json
txin1 <- H.noteShow =<< H.headM (Map.keys utxo1)

let node1SocketPath = Api.File $ IO.sprocketSystemName node1sprocket
nodeConfigFile = Api.File configurationFile
termEpoch = 15
(stakePoolId, stakePoolColdSigningKey, stakePoolColdVKey, _, _)
<- registerSingleSpo 1 tempAbsPath cTestnetOptions execConfig (txin1, utxoSKeyFile, utxoAddr)
<- registerSingleSpo 1 tempAbsPath
nodeConfigFile
node1SocketPath
termEpoch
cTestnetOptions
execConfig
(txin1, utxoSKeyFile, utxoAddr)

-- Create test stake address to delegate to the new stake pool
-- NB: We need to fund the payment credential of the overall address
Expand Down Expand Up @@ -185,11 +195,12 @@ hprop_kes_period_info = H.integrationRetryWorkspace 2 "kes-period-info" $ \tempA
, "--tx-file", delegRegTestDelegatorTxFp
]

threadDelay 20_000_000

let testDelegatorStakeAddressInfoOutFp = work </> "test-delegator-stake-address-info.json"
void $ checkStakeKeyRegistered
tempAbsPath
nodeConfigFile
node1SocketPath
termEpoch
execConfig
testDelegatorStakeAddress
testDelegatorStakeAddressInfoOutFp
Expand Down

0 comments on commit 1b9cbaa

Please sign in to comment.