diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml index 9b4e18ab021..73b4d950692 100644 --- a/.stylish-haskell.yaml +++ b/.stylish-haskell.yaml @@ -86,7 +86,6 @@ language_extensions: - LambdaCase - MultiParamTypeClasses - MultiWayIf - - NoImplicitPrelude - OverloadedStrings - PolyKinds - RecordWildCards diff --git a/cabal.project b/cabal.project index 80c8cb73e98..34eae9b8934 100644 --- a/cabal.project +++ b/cabal.project @@ -168,8 +168,8 @@ source-repository-package source-repository-package type: git location: https://github.com/input-output-hk/hedgehog-extras - tag: 967d79533c21e33387d0227a5f6cc185203fe658 - --sha256: 0rbqb7a64aya1qizlr3im06hdydg9zr6sl3i8bvqqlf7kpa647sd + tag: 714ee03a5a786a05fc57ac5d2f1c2edce4660d85 + --sha256: 1qa4mm36xynaf17990ijmzww0ij8hjrc0vw5nas6d0zx6q9hb978 source-repository-package type: git diff --git a/cardano-api/src/Cardano/Api/LedgerState.hs b/cardano-api/src/Cardano/Api/LedgerState.hs index 26cf155c012..bf0674fd1ea 100644 --- a/cardano-api/src/Cardano/Api/LedgerState.hs +++ b/cardano-api/src/Cardano/Api/LedgerState.hs @@ -57,6 +57,7 @@ import Control.Monad (when) import Control.Monad.Trans.Class import Control.Monad.Trans.Except import Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistEither, left) +import Control.State.Transition import Data.Aeson as Aeson import qualified Data.Aeson.Types as Data.Aeson.Types.Internal import Data.Bifunctor @@ -68,15 +69,16 @@ import qualified Data.ByteString.Lazy as LB import Data.ByteString.Short as BSS import Data.Foldable import Data.IORef +import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (mapMaybe) -import Data.Proxy (Proxy(Proxy)) -import Data.SOP.Strict (NP (..)) +import Data.Proxy (Proxy (Proxy)) import Data.Sequence (Seq) import qualified Data.Sequence as Seq import Data.Set (Set) import qualified Data.Set as Set import Data.Sharing (FromSharedCBOR, Interns, Share) +import Data.SOP.Strict (NP (..)) import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text @@ -86,6 +88,7 @@ import Data.Word import qualified Data.Yaml as Yaml import Formatting.Buildable (build) import GHC.Records (HasField (..)) +import Network.TypedProtocol.Pipelined (Nat (..)) import System.FilePath import Cardano.Api.Block @@ -113,24 +116,27 @@ import qualified Cardano.Crypto.Hash.Class import qualified Cardano.Crypto.Hashing import qualified Cardano.Crypto.ProtocolMagic import qualified Cardano.Crypto.VRF as Crypto +import qualified Cardano.Crypto.VRF.Class as VRF import Cardano.Ledger.Alonzo.Genesis (AlonzoGenesis (..)) -import qualified Cardano.Ledger.BHeaderView as Ledger -import Cardano.Ledger.BaseTypes (Globals (..), UnitInterval, (⭒)) +import Cardano.Ledger.BaseTypes (Globals (..), Nonce, UnitInterval, (⭒)) import qualified Cardano.Ledger.BaseTypes as Shelley.Spec +import qualified Cardano.Ledger.BHeaderView as Ledger import qualified Cardano.Ledger.Core as Core import qualified Cardano.Ledger.Credential as Shelley.Spec +import qualified Cardano.Ledger.Era import qualified Cardano.Ledger.Era as Ledger import qualified Cardano.Ledger.Keys as Shelley.Spec +import qualified Cardano.Ledger.Keys as SL +import qualified Cardano.Ledger.PoolDistr as SL import qualified Cardano.Ledger.Shelley.API as ShelleyAPI import qualified Cardano.Ledger.Shelley.Genesis as Shelley.Spec import qualified Cardano.Protocol.TPraos.API as TPraos +import Cardano.Protocol.TPraos.BHeader (checkLeaderNatValue) import qualified Cardano.Protocol.TPraos.BHeader as TPraos import Cardano.Slotting.EpochInfo (EpochInfo) import qualified Cardano.Slotting.EpochInfo.API as Slot import Cardano.Slotting.Slot (WithOrigin (At, Origin)) import qualified Cardano.Slotting.Slot as Slot -import Control.State.Transition -import Network.TypedProtocol.Pipelined (Nat (..)) import qualified Ouroboros.Consensus.Block.Abstract as Consensus import qualified Ouroboros.Consensus.Byron.Ledger.Block as Byron import qualified Ouroboros.Consensus.Cardano as Consensus @@ -146,8 +152,10 @@ import Ouroboros.Consensus.Ledger.Basics (LedgerResult (lrEvents), lrR import qualified Ouroboros.Consensus.Ledger.Extended as Ledger import qualified Ouroboros.Consensus.Mempool.TxLimits as TxLimits import qualified Ouroboros.Consensus.Node.ProtocolInfo as Consensus +import Ouroboros.Consensus.Protocol.Abstract (ChainDepState, ConsensusProtocol (..)) import qualified Ouroboros.Consensus.Protocol.Abstract as Consensus import qualified Ouroboros.Consensus.Protocol.Praos.Common as Consensus +import Ouroboros.Consensus.Protocol.Praos.VRF (mkInputVRF, vrfLeaderValue) import qualified Ouroboros.Consensus.Protocol.TPraos as TPraos import qualified Ouroboros.Consensus.Shelley.Eras as Shelley import qualified Ouroboros.Consensus.Shelley.Ledger.Block as Shelley @@ -1309,7 +1317,7 @@ nextEpochEligibleLeadershipSlots :: forall era. HasField "_d" (Core.PParams (ShelleyLedgerEra era)) UnitInterval => Ledger.Era (ShelleyLedgerEra era) - => Share (Core.TxOut (ShelleyLedgerEra era)) ~ Interns (Shelley.Spec.Credential 'Shelley.Spec.Staking (Ledger.Crypto (ShelleyLedgerEra era))) + => Share (Core.TxOut (ShelleyLedgerEra era)) ~ Interns (Shelley.Spec.Credential 'Shelley.Spec.Staking (Cardano.Ledger.Era.Crypto (ShelleyLedgerEra era))) => FromCBOR (Consensus.ChainDepState (Api.ConsensusProtocol era)) => Consensus.PraosProtocolSupportsNode (Api.ConsensusProtocol era) => ShelleyBasedEra era @@ -1326,14 +1334,11 @@ nextEpochEligibleLeadershipSlots -> EpochInfo (Either Text) -> (ChainTip, EpochNo) -> Either LeadershipError (Set SlotNo) -nextEpochEligibleLeadershipSlots sbe sGen serCurrEpochState ptclState - poolid@(StakePoolKeyHash poolHash) (VrfSigningKey vrfSkey) pParams - eInfo (cTip, currentEpoch) = do - +nextEpochEligibleLeadershipSlots sbe sGen serCurrEpochState ptclState poolid (VrfSigningKey vrfSkey) pParams eInfo (cTip, currentEpoch) = do (_, currentEpochLastSlot) <- first LeaderErrSlotRangeCalculationFailure $ Slot.epochInfoRange eInfo currentEpoch - rOfInterest <- first LeaderErrSlotRangeCalculationFailure + (firstSlotOfEpoch, lastSlotofEpoch) <- first LeaderErrSlotRangeCalculationFailure $ Slot.epochInfoRange eInfo (currentEpoch + 1) @@ -1379,14 +1384,21 @@ nextEpochEligibleLeadershipSlots sbe sGen serCurrEpochState ptclState $ obtainDecodeEpochStateConstraints sbe $ decodeCurrentEpochState serCurrEpochState - let markSnapshotPoolDistr = ShelleyAPI.unPoolDistr . ShelleyAPI.calculatePoolDistr . ShelleyAPI._pstakeMark + let markSnapshotPoolDistr :: Map (SL.KeyHash 'SL.StakePool Shelley.StandardCrypto) (SL.IndividualPoolStake Shelley.StandardCrypto) + markSnapshotPoolDistr = ShelleyAPI.unPoolDistr . ShelleyAPI.calculatePoolDistr . ShelleyAPI._pstakeMark $ obtainIsStandardCrypto sbe $ ShelleyAPI.esSnapshots cEstate + let slotRangeOfInterest = Set.filter + (not . Ledger.isOverlaySlot firstSlotOfEpoch (getField @"_d" (toLedgerPParams sbe pParams))) + $ Set.fromList [firstSlotOfEpoch .. lastSlotofEpoch] - relativeStake <- maybe (Left $ LeaderErrStakePoolHasNoStake poolid) - (Right . ShelleyAPI.individualPoolStake) $ Map.lookup poolHash markSnapshotPoolDistr + case sbe of + ShelleyBasedEraShelley -> isLeadingSlotsTPraos slotRangeOfInterest poolid markSnapshotPoolDistr nextEpochsNonce vrfSkey f + ShelleyBasedEraAllegra -> isLeadingSlotsTPraos slotRangeOfInterest poolid markSnapshotPoolDistr nextEpochsNonce vrfSkey f + ShelleyBasedEraMary -> isLeadingSlotsTPraos slotRangeOfInterest poolid markSnapshotPoolDistr nextEpochsNonce vrfSkey f + ShelleyBasedEraAlonzo -> isLeadingSlotsTPraos slotRangeOfInterest poolid markSnapshotPoolDistr nextEpochsNonce vrfSkey f + ShelleyBasedEraBabbage -> isLeadingSlotsPraos slotRangeOfInterest poolid markSnapshotPoolDistr nextEpochsNonce vrfSkey f - return $ isLeadingSlots sbe rOfInterest nextEpochsNonce pParams vrfSkey relativeStake f where globals = constructGlobals sGen eInfo pParams @@ -1410,46 +1422,53 @@ nextEpochEligibleLeadershipSlots sbe sGen serCurrEpochState ptclState -- See Leader Value Calculation in the Shelley ledger specification. -- We need the certified natural value from the VRF, active slot coefficient -- and the stake proportion of the stake pool. -isLeadingSlots - :: Crypto.Signable v Shelley.Spec.Seed +isLeadingSlotsTPraos :: forall v. () + => Crypto.Signable v Shelley.Spec.Seed => Crypto.VRFAlgorithm v => Crypto.ContextVRF v ~ () - => HasField "_d" (Core.PParams (ShelleyLedgerEra era)) UnitInterval - => ShelleyBasedEra era - -> (SlotNo, SlotNo) -- ^ Slot range of interest + => Set SlotNo + -> PoolId + -> Map (SL.KeyHash 'SL.StakePool Shelley.StandardCrypto) (SL.IndividualPoolStake Shelley.StandardCrypto) -> Consensus.Nonce - -> ProtocolParameters -> Crypto.SignKeyVRF v - -> Rational -- ^ Stake pool relative stake -> Shelley.Spec.ActiveSlotCoeff - -> Set SlotNo -isLeadingSlots sbe (firstSlotOfEpoch, lastSlotofEpoch) eNonce pParams vrfSkey - stakePoolStake activeSlotCoeff' = - let certified s = certifiedNaturalValue s eNonce vrfSkey - pp = toLedgerPParams sbe pParams - slotRangeOfInterest = Set.fromList [firstSlotOfEpoch .. lastSlotofEpoch] - - isLeader s = not (Ledger.isOverlaySlot firstSlotOfEpoch (getField @"_d" pp) s) - && TPraos.checkLeaderValue (certified s) - stakePoolStake activeSlotCoeff' - in Set.filter isLeader slotRangeOfInterest - where - certifiedNaturalValue - :: Crypto.Signable v Shelley.Spec.Seed - => Crypto.VRFAlgorithm v - => Crypto.ContextVRF v ~ () - => SlotNo - -> Consensus.Nonce - -> Crypto.SignKeyVRF v - -> Crypto.OutputVRF v - certifiedNaturalValue slot epochNonce vrfSkey' = - Crypto.certifiedOutput - $ Crypto.evalCertified () (TPraos.mkSeed TPraos.seedL slot epochNonce) vrfSkey' + -> Either LeadershipError (Set SlotNo) +isLeadingSlotsTPraos slotRangeOfInterest poolid snapshotPoolDistr eNonce vrfSkey activeSlotCoeff' = do + let StakePoolKeyHash poolHash = poolid + + let certifiedVrf s = Crypto.evalCertified () (TPraos.mkSeed TPraos.seedL s eNonce) vrfSkey + + stakePoolStake <- maybe (Left $ LeaderErrStakePoolHasNoStake poolid) Right $ + ShelleyAPI.individualPoolStake <$> Map.lookup poolHash snapshotPoolDistr + + let isLeader s = TPraos.checkLeaderValue (Crypto.certifiedOutput (certifiedVrf s)) stakePoolStake activeSlotCoeff' + + return $ Set.filter isLeader slotRangeOfInterest + +isLeadingSlotsPraos :: () + => Set SlotNo + -> PoolId + -> Map (SL.KeyHash 'SL.StakePool Shelley.StandardCrypto) (SL.IndividualPoolStake Shelley.StandardCrypto) + -> Consensus.Nonce + -> SL.SignKeyVRF Shelley.StandardCrypto + -> Shelley.Spec.ActiveSlotCoeff + -> Either LeadershipError (Set SlotNo) +isLeadingSlotsPraos slotRangeOfInterest poolid snapshotPoolDistr eNonce vrfSkey activeSlotCoeff' = do + let StakePoolKeyHash poolHash = poolid + + stakePoolStake <- maybe (Left $ LeaderErrStakePoolHasNoStake poolid) Right $ + ShelleyAPI.individualPoolStake <$> Map.lookup poolHash snapshotPoolDistr + + let isLeader slotNo = checkLeaderNatValue certifiedNatValue stakePoolStake activeSlotCoeff' + where rho = VRF.evalCertified () (mkInputVRF slotNo eNonce) vrfSkey + certifiedNatValue = vrfLeaderValue (Proxy @Shelley.StandardCrypto) rho + + Right $ Set.filter isLeader slotRangeOfInterest obtainIsStandardCrypto :: ShelleyLedgerEra era ~ ledgerera => ShelleyBasedEra era - -> (Ledger.Crypto ledgerera ~ Shelley.StandardCrypto => a) + -> (Cardano.Ledger.Era.Crypto ledgerera ~ Shelley.StandardCrypto => a) -> a obtainIsStandardCrypto ShelleyBasedEraShelley f = f obtainIsStandardCrypto ShelleyBasedEraAllegra f = f @@ -1474,14 +1493,13 @@ obtainDecodeEpochStateConstraints ShelleyBasedEraBabbage f = f -- | Return the slots at which a particular stake pool operator is -- expected to mint a block. -currentEpochEligibleLeadershipSlots - :: forall era ledgerera . - ShelleyLedgerEra era ~ ledgerera +currentEpochEligibleLeadershipSlots :: forall era ledgerera. () + => ShelleyLedgerEra era ~ ledgerera => Ledger.Era ledgerera => Consensus.PraosProtocolSupportsNode (Api.ConsensusProtocol era) => HasField "_d" (Core.PParams ledgerera) UnitInterval -- => Crypto.Signable (Crypto.VRF (Ledger.Crypto ledgerera)) Shelley.Spec.Seed - => Share (Core.TxOut (ShelleyLedgerEra era)) ~ Interns (Shelley.Spec.Credential 'Shelley.Spec.Staking (Ledger.Crypto (ShelleyLedgerEra era))) + => Share (Core.TxOut (ShelleyLedgerEra era)) ~ Interns (Shelley.Spec.Credential 'Shelley.Spec.Staking (Cardano.Ledger.Era.Crypto (ShelleyLedgerEra era))) -- => Ledger.Crypto ledgerera ~ Shelley.StandardCrypto => FromCBOR (Consensus.ChainDepState (Api.ConsensusProtocol era)) -- => Consensus.ChainDepState (ConsensusProtocol era) ~ Consensus.ChainDepState (ConsensusProtocol era) @@ -1495,35 +1513,41 @@ currentEpochEligibleLeadershipSlots -> SerialisedCurrentEpochState era -> EpochNo -- ^ Current EpochInfo -> Either LeadershipError (Set SlotNo) -currentEpochEligibleLeadershipSlots sbe sGen eInfo pParams ptclState - poolid@(StakePoolKeyHash poolHash) (VrfSigningKey vrkSkey) - serCurrEpochState currentEpoch = do +currentEpochEligibleLeadershipSlots sbe sGen eInfo pParams ptclState poolid (VrfSigningKey vrkSkey) serCurrEpochState currentEpoch = do - chainDepState <- first LeaderErrDecodeProtocolStateFailure - $ decodeProtocolState ptclState + chainDepState :: ChainDepState (Api.ConsensusProtocol era) <- + first LeaderErrDecodeProtocolStateFailure $ decodeProtocolState ptclState -- We use the current epoch's nonce for the current leadership schedule -- calculation because the TICKN transition updates the epoch nonce -- at the start of the epoch. - let epochNonce = Consensus.epochNonce (Consensus.getPraosNonces (Proxy @(Api.ConsensusProtocol era)) chainDepState) - currentEpochRange <- first LeaderErrSlotRangeCalculationFailure - $ Slot.epochInfoRange eInfo currentEpoch + let epochNonce :: Nonce = Consensus.epochNonce (Consensus.getPraosNonces (Proxy @(Api.ConsensusProtocol era)) chainDepState) - CurrentEpochState cEstate <- first LeaderErrDecodeProtocolEpochStateFailure - $ obtainDecodeEpochStateConstraints sbe - $ decodeCurrentEpochState serCurrEpochState + (firstSlotOfEpoch, lastSlotofEpoch) :: (SlotNo, SlotNo) <- first LeaderErrSlotRangeCalculationFailure + $ Slot.epochInfoRange eInfo currentEpoch + + CurrentEpochState (cEstate :: ShelleyAPI.EpochState (ShelleyLedgerEra era)) <- + first LeaderErrDecodeProtocolEpochStateFailure + $ obtainDecodeEpochStateConstraints sbe + $ decodeCurrentEpochState serCurrEpochState -- We need the "set" stake distribution (distribution of the previous epoch) -- in order to calculate the leadership schedule of the current epoch. - let setSnapshotPoolDistr = ShelleyAPI.unPoolDistr . ShelleyAPI.calculatePoolDistr + let setSnapshotPoolDistr :: Map (SL.KeyHash 'SL.StakePool Shelley.StandardCrypto) (SL.IndividualPoolStake Shelley.StandardCrypto) + setSnapshotPoolDistr = ShelleyAPI.unPoolDistr . ShelleyAPI.calculatePoolDistr . ShelleyAPI._pstakeSet . obtainIsStandardCrypto sbe $ ShelleyAPI.esSnapshots cEstate - relativeStake <- maybe (Left $ LeaderErrStakePoolHasNoStake poolid) - (Right . ShelleyAPI.individualPoolStake) - (Map.lookup poolHash setSnapshotPoolDistr) + let slotRangeOfInterest = Set.filter + (not . Ledger.isOverlaySlot firstSlotOfEpoch (getField @"_d" (toLedgerPParams sbe pParams))) + $ Set.fromList [firstSlotOfEpoch .. lastSlotofEpoch] - Right $ isLeadingSlots sbe currentEpochRange epochNonce pParams vrkSkey relativeStake f + case sbe of + ShelleyBasedEraShelley -> isLeadingSlotsTPraos slotRangeOfInterest poolid setSnapshotPoolDistr epochNonce vrkSkey f + ShelleyBasedEraAllegra -> isLeadingSlotsTPraos slotRangeOfInterest poolid setSnapshotPoolDistr epochNonce vrkSkey f + ShelleyBasedEraMary -> isLeadingSlotsTPraos slotRangeOfInterest poolid setSnapshotPoolDistr epochNonce vrkSkey f + ShelleyBasedEraAlonzo -> isLeadingSlotsTPraos slotRangeOfInterest poolid setSnapshotPoolDistr epochNonce vrkSkey f + ShelleyBasedEraBabbage -> isLeadingSlotsPraos slotRangeOfInterest poolid setSnapshotPoolDistr epochNonce vrkSkey f where globals = constructGlobals sGen eInfo pParams diff --git a/cardano-testnet/cardano-testnet.cabal b/cardano-testnet/cardano-testnet.cabal index 9785364fa37..11a3204bc6a 100644 --- a/cardano-testnet/cardano-testnet.cabal +++ b/cardano-testnet/cardano-testnet.cabal @@ -50,11 +50,15 @@ library , safe-exceptions , text , time + , transformers , unordered-containers hs-source-dirs: src - exposed-modules: Test.Base + exposed-modules: Test.Assert + Test.Base Test.Process + Test.Runtime + Testnet.Babbage Testnet.Byron Testnet.Cardano Testnet.Conf @@ -84,6 +88,7 @@ executable cardano-testnet other-modules: Paths_cardano_testnet Testnet.Commands + Testnet.Commands.Babbage Testnet.Commands.Byron Testnet.Commands.Cardano Testnet.Commands.Shelley @@ -117,8 +122,11 @@ test-suite cardano-testnet-tests , tasty-expected-failure , tasty-hedgehog , text + , time other-modules: + Spec.Cli.Alonzo.LeadershipSchedule + Spec.Cli.Babbage.LeadershipSchedule Spec.Cli.KesPeriodInfo Spec.Node.Shutdown Spec.ShutdownOnSlotSynced diff --git a/cardano-testnet/src/Test/Assert.hs b/cardano-testnet/src/Test/Assert.hs new file mode 100644 index 00000000000..a9729bddc05 --- /dev/null +++ b/cardano-testnet/src/Test/Assert.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +{- HLINT ignore "Redundant return" -} + +module Test.Assert + ( readJsonLines + , assertChainExtended + , getRelevantLeaderSlots + ) where + +import Control.Applicative ((<*>)) +import Control.Monad (Monad (..)) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans.Reader (ReaderT) +import Control.Monad.Trans.Resource (ResourceT) +import Data.Aeson (FromJSON (..), Value, (.:)) +import Data.Bool (Bool (..)) +import Data.Eq (Eq (..)) +import Data.Function (($), (.)) +import Data.Functor ((<$>)) +import Data.Int (Int) +import Data.Maybe (Maybe (..), mapMaybe) +import Data.Ord (Ord (..)) +import Data.Text (Text) +import Data.Word (Word8) +import GHC.Stack (HasCallStack) +import Hedgehog (MonadTest) +import Hedgehog.Extras.Internal.Test.Integration (IntegrationState) +import System.FilePath (FilePath) +import System.IO (IO) +import Test.Runtime (NodeLoggingFormat (..)) +import Text.Show (Show (..)) + +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson +import qualified Data.ByteString.Lazy as LBS +import qualified Data.List as L +import qualified Data.Maybe as Maybe +import qualified Data.Time.Clock as DTC +import qualified Hedgehog as H +import qualified Hedgehog.Extras.Stock.IO.File as IO +import qualified Hedgehog.Extras.Test.Base as H +import qualified Test.Process as H + +newlineBytes :: Word8 +newlineBytes = 10 + +readJsonLines :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> m [Value] +readJsonLines fp = mapMaybe (Aeson.decode @Value) . LBS.split newlineBytes <$> H.evalIO (LBS.readFile fp) + +fileJsonGrep :: FilePath -> (Value -> Bool) -> IO Bool +fileJsonGrep fp f = do + lines <- LBS.split newlineBytes <$> LBS.readFile fp + let jsons = mapMaybe (Aeson.decode @Value) lines + return $ L.any f jsons + +assertChainExtended :: (H.MonadTest m, MonadIO m) + => DTC.UTCTime + -> NodeLoggingFormat + -> FilePath + -> m () +assertChainExtended deadline nodeLoggingFormat nodeStdoutFile = + H.assertByDeadlineIOCustom "Chain not extended" deadline $ do + case nodeLoggingFormat of + NodeLoggingFormatAsText -> IO.fileContains "Chain extended, new tip" nodeStdoutFile + NodeLoggingFormatAsJson -> fileJsonGrep nodeStdoutFile $ \v -> + Aeson.parseMaybe (Aeson.parseJSON @(LogEntry Kind)) v == Just (LogEntry (Kind "TraceAddBlockEvent.AddedToCurrentChain")) + +newtype LogEntry a = LogEntry + { unLogEntry :: a + } deriving (Eq, Show) + +instance FromJSON a => FromJSON (LogEntry a) where + parseJSON = Aeson.withObject "LogEntry" $ \v -> + LogEntry <$> v .: "data" + +newtype Kind = Kind + { kind :: Text + } deriving (Eq, Show) + +data TraceNodeIsLeader = TraceNodeIsLeader + { kind :: Text + , slot :: Int + } deriving (Eq, Show) + +instance FromJSON TraceNodeIsLeader where + parseJSON = Aeson.withObject "TraceNodeIsLeader" $ \v -> + TraceNodeIsLeader + <$> v .: "kind" + <*> v .: "slot" + +instance FromJSON Kind where + parseJSON = Aeson.withObject "Kind" $ \v -> + Kind <$> v .: "kind" + +getRelevantLeaderSlots :: FilePath -> Int -> H.PropertyT (ReaderT IntegrationState (ResourceT IO)) [Int] +getRelevantLeaderSlots poolNodeStdoutFile slotLowerBound = do + vs <- readJsonLines poolNodeStdoutFile + leaderSlots <- H.noteShow + $ L.map (slot . unLogEntry) + $ Maybe.mapMaybe (Aeson.parseMaybe (Aeson.parseJSON @(LogEntry TraceNodeIsLeader))) + vs + relevantLeaderSlots <- H.noteShow + $ L.filter (>= slotLowerBound) + leaderSlots + return relevantLeaderSlots diff --git a/cardano-testnet/src/Test/Base.hs b/cardano-testnet/src/Test/Base.hs index 43e171ce22a..86608eec3e5 100644 --- a/cardano-testnet/src/Test/Base.hs +++ b/cardano-testnet/src/Test/Base.hs @@ -1,12 +1,20 @@ module Test.Base ( integration + , isLinux ) where +import Data.Bool (Bool) +import Data.Eq (Eq (..)) import Data.Function import GHC.Stack (HasCallStack) +import System.Info (os) import qualified Hedgehog as H import qualified Hedgehog.Extras.Test.Base as H + integration :: HasCallStack => H.Integration () -> H.Property integration = H.withTests 1 . H.propertyOnce + +isLinux :: Bool +isLinux = os == "linux" diff --git a/cardano-testnet/src/Test/Process.hs b/cardano-testnet/src/Test/Process.hs index 23ef50616c3..5a12b5d08e4 100644 --- a/cardano-testnet/src/Test/Process.hs +++ b/cardano-testnet/src/Test/Process.hs @@ -1,5 +1,6 @@ module Test.Process ( assertByDeadlineIOCustom + , assertByDeadlineMCustom , bashPath , execCli , execCli' @@ -130,3 +131,18 @@ assertByDeadlineIOCustom str deadline f = GHC.withFrozenCallStack $ do else do H.annotateShow currentTime failMessage GHC.callStack $ "Condition not met by deadline: " <> str + +assertByDeadlineMCustom + :: (MonadTest m, MonadIO m, HasCallStack) + => String -> UTCTime -> m Bool -> m () +assertByDeadlineMCustom str deadline f = GHC.withFrozenCallStack $ do + success <- f + unless success $ do + currentTime <- liftIO DTC.getCurrentTime + if currentTime < deadline + then do + liftIO $ IO.threadDelay 1000000 + assertByDeadlineMCustom str deadline f + else do + H.annotateShow currentTime + failMessage GHC.callStack $ "Condition not met by deadline: " <> str diff --git a/cardano-testnet/src/Test/Runtime.hs b/cardano-testnet/src/Test/Runtime.hs new file mode 100644 index 00000000000..1f39e646927 --- /dev/null +++ b/cardano-testnet/src/Test/Runtime.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Test.Runtime + ( LeadershipSlot(..) + , NodeLoggingFormat(..) + , PaymentKeyPair(..) + , StakingKeyPair(..) + , TestnetRuntime(..) + , TestnetNode(..) + , PoolNode(..) + , PoolNodeKeys(..) + , Delegator(..) + , bftSprockets + , poolSprockets + , poolNodeToTestnetNode + , readNodeLoggingFormat + ) where + +import Data.Aeson (FromJSON) +import Data.Either (Either (..)) +import Data.Eq (Eq) +import Data.Function (($), (.)) +import Data.Functor (fmap) +import Data.Int (Int) +import Data.Semigroup (Semigroup ((<>))) +import Data.String (String) +import Data.Text (Text) +import GHC.Generics (Generic) +import Hedgehog.Extras.Stock.IO.Network.Sprocket (Sprocket (..)) +import System.IO (FilePath) +import Text.Show (Show (..)) + +import qualified System.IO as IO +import qualified System.Process as IO + +data NodeLoggingFormat = NodeLoggingFormatAsJson | NodeLoggingFormatAsText deriving (Eq, Show) + +data TestnetRuntime = TestnetRuntime + { configurationFile :: FilePath + , shelleyGenesisFile :: FilePath + , testnetMagic :: Int + , bftNodes :: [TestnetNode] + , poolNodes :: [PoolNode] + , wallets :: [PaymentKeyPair] + , delegators :: [Delegator] + } + +data TestnetNode = TestnetNode + { nodeName :: String + , nodeSprocket :: Sprocket + , nodeStdinHandle :: IO.Handle + , nodeStdout :: FilePath + , nodeStderr :: FilePath + , nodeProcessHandle :: IO.ProcessHandle + } + +data PoolNode = PoolNode + { poolNodeName :: String + , poolNodeSprocket :: Sprocket + , poolNodeStdinHandle :: IO.Handle + , poolNodeStdout :: FilePath + , poolNodeStderr :: FilePath + , poolNodeProcessHandle :: IO.ProcessHandle + , poolNodeKeys :: PoolNodeKeys + } + +data PoolNodeKeys = PoolNodeKeys + { poolNodeKeysColdVkey :: FilePath + , poolNodeKeysColdSkey :: FilePath + , poolNodeKeysVrfVkey :: FilePath + , poolNodeKeysVrfSkey :: FilePath + , poolNodeKeysStakingVkey :: FilePath + , poolNodeKeysStakingSkey :: FilePath + } deriving (Eq, Show) + +data PaymentKeyPair = PaymentKeyPair + { paymentVKey :: FilePath + , paymentSKey :: FilePath + } deriving (Eq, Show) + +data StakingKeyPair = StakingKeyPair + { stakingVKey :: FilePath + , stakingSKey :: FilePath + } deriving (Eq, Show) + +data Delegator = Delegator + { paymentKeyPair :: PaymentKeyPair + , stakingKeyPair :: StakingKeyPair + } deriving (Eq, Show) + +data LeadershipSlot = LeadershipSlot + { slotNumber :: Int + , slotTime :: Text + } deriving (Eq, Show, Generic, FromJSON) + +poolNodeToTestnetNode :: PoolNode -> TestnetNode +poolNodeToTestnetNode PoolNode + { poolNodeName + , poolNodeSprocket + , poolNodeStdinHandle + , poolNodeStdout + , poolNodeStderr + , poolNodeProcessHandle + } = TestnetNode + { nodeName = poolNodeName + , nodeSprocket = poolNodeSprocket + , nodeStdinHandle = poolNodeStdinHandle + , nodeStdout = poolNodeStdout + , nodeStderr = poolNodeStderr + , nodeProcessHandle = poolNodeProcessHandle + } + +bftSprockets :: TestnetRuntime -> [Sprocket] +bftSprockets = fmap nodeSprocket . bftNodes + +poolSprockets :: TestnetRuntime -> [Sprocket] +poolSprockets = fmap poolNodeSprocket . poolNodes + +readNodeLoggingFormat :: String -> Either String NodeLoggingFormat +readNodeLoggingFormat = \case + "json" -> Right NodeLoggingFormatAsJson + "text" -> Right NodeLoggingFormatAsText + s -> Left $ "Unrecognised node logging format: " <> show s <> ". Valid options: \"json\", \"text\"" diff --git a/cardano-testnet/src/Testnet/Babbage.hs b/cardano-testnet/src/Testnet/Babbage.hs new file mode 100644 index 00000000000..bf73e8af686 --- /dev/null +++ b/cardano-testnet/src/Testnet/Babbage.hs @@ -0,0 +1,415 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +{-# OPTIONS_GHC -Wno-unused-local-binds -Wno-unused-matches #-} + +module Testnet.Babbage + ( TestnetOptions(..) + , defaultTestnetOptions + , TestnetNodeOptions(..) + , defaultTestnetNodeOptions + + , TestnetRuntime (..) + , TestnetNode (..) + , PaymentKeyPair(..) + + , testnet + ) where + +import Control.Applicative (Applicative (..)) +import Control.Monad (Monad (..), fmap, forM, forM_, return, void, when, (=<<)) +import Data.Aeson (encode, object, toJSON, (.=)) +import Data.Bool (Bool (..)) +import Data.Eq (Eq) +import Data.Function (flip, ($), (.)) +import Data.Functor ((<$>), (<&>)) +import Data.Int (Int) +import Data.Maybe (Maybe (..)) +import Data.Ord (Ord ((<=))) +import Data.Semigroup (Semigroup ((<>))) +import Data.String (String) +import GHC.Float (Double) +import Hedgehog.Extras.Stock.IO.Network.Sprocket (Sprocket (..)) +import Hedgehog.Extras.Stock.Time (showUTCTimeSeconds) +import System.FilePath.Posix (()) +import Test.Runtime (Delegator (..), NodeLoggingFormat (..), PaymentKeyPair (..), + PoolNode (PoolNode), PoolNodeKeys (..), StakingKeyPair (..), TestnetNode (..), + TestnetRuntime (..)) +import Text.Show (Show (show)) + +import qualified Data.HashMap.Lazy as HM +import qualified Data.List as L +import qualified Data.Time.Clock as DTC +import qualified Hedgehog as H +import qualified Hedgehog.Extras.Stock.Aeson as J +import qualified Hedgehog.Extras.Stock.IO.Network.Sprocket as IO +import qualified Hedgehog.Extras.Stock.OS as OS +import qualified Hedgehog.Extras.Stock.String as S +import qualified Hedgehog.Extras.Test.Base as H +import qualified Hedgehog.Extras.Test.File as H +import qualified Hedgehog.Extras.Test.Process as H +import qualified System.Info as OS +import qualified System.IO as IO +import qualified System.Process as IO +import qualified Test.Assert as H +import qualified Test.Process as H +import qualified Testnet.Conf as H + +{- HLINT ignore "Reduce duplication" -} +{- HLINT ignore "Redundant <&>" -} +{- HLINT ignore "Redundant flip" -} +{- HLINT ignore "Redundant id" -} +{- HLINT ignore "Use let" -} + +data TestnetOptions = TestnetOptions + { numSpoNodes :: Int + , slotDuration :: Int + , securityParam :: Int + , totalBalance :: Int + , nodeLoggingFormat :: NodeLoggingFormat + } deriving (Eq, Show) + +defaultTestnetOptions :: TestnetOptions +defaultTestnetOptions = TestnetOptions + { numSpoNodes = 3 + , slotDuration = 1000 + , securityParam = 10 + , totalBalance = 10020000000 + , nodeLoggingFormat = NodeLoggingFormatAsJson + } + +data TestnetNodeOptions = TestnetNodeOptions deriving (Eq, Show) + +defaultTestnetNodeOptions :: TestnetNodeOptions +defaultTestnetNodeOptions = TestnetNodeOptions + +-- | For an unknown reason, CLI commands are a lot slower on Windows than on Linux and +-- MacOS. We need to allow a lot more time to set up a testnet. +startTimeOffsetSeconds :: DTC.NominalDiffTime +startTimeOffsetSeconds = if OS.isWin32 then 90 else 15 + +testnet :: TestnetOptions -> H.Conf -> H.Integration TestnetRuntime +testnet testnetOptions H.Conf {..} = do + H.createDirectoryIfMissing (tempAbsPath "logs") + + H.lbsWriteFile (tempAbsPath "byron.genesis.spec.json") . encode $ object + [ "heavyDelThd" .= ("300000000000" :: String) + , "maxBlockSize" .= ("2000000" :: String) + , "maxTxSize" .= ("4096" :: String) + , "maxHeaderSize" .= ("2000000" :: String) + , "maxProposalSize" .= ("700" :: String) + , "mpcThd" .= ("20000000000000" :: String) + , "scriptVersion" .= (0 :: Int) + , "slotDuration" .= show @Int (slotDuration testnetOptions) + , "unlockStakeEpoch" .= ("18446744073709551615" :: String) + , "updateImplicit" .= ("10000" :: String) + , "updateProposalThd" .= ("100000000000000" :: String) + , "updateVoteThd" .= ("1000000000000" :: String) + , "softforkRule" .= object + [ "initThd" .= ("900000000000000" :: String) + , "minThd" .= ("600000000000000" :: String) + , "thdDecrement" .= ("50000000000000" :: String) + ] + , "txFeePolicy" .= object + [ "multiplier" .= ("43946000000" :: String) + , "summand" .= ("155381000000000" :: String) + ] + ] + + void $ H.note OS.os + currentTime <- H.noteShowIO DTC.getCurrentTime + startTime <- H.noteShow $ DTC.addUTCTime startTimeOffsetSeconds currentTime + + void . H.execCli $ + [ "byron", "genesis", "genesis" + , "--protocol-magic", show @Int testnetMagic + , "--start-time", showUTCTimeSeconds startTime + , "--k", show @Int (securityParam testnetOptions) + , "--n-poor-addresses", "0" + , "--n-delegate-addresses", show @Int (numSpoNodes testnetOptions) + , "--total-balance", show @Int (totalBalance testnetOptions) + , "--delegate-share", "1" + , "--avvm-entry-count", "0" + , "--avvm-entry-balance", "0" + , "--protocol-parameters-file", tempAbsPath "byron.genesis.spec.json" + , "--genesis-output-dir", tempAbsPath "byron-gen-command" + ] + + -- Because in Babbage the overlay schedule and decentralization parameter + -- are deprecated, we must use the "create-staked" cli command to create + -- SPOs in the ShelleyGenesis + + alonzoBabbageTestGenesisJsonSourceFile <- H.noteShow $ base "scripts/babbage/alonzo-babbage-test-genesis.json" + alonzoBabbageTestGenesisJsonTargetFile <- H.noteShow $ tempAbsPath "genesis.alonzo.spec.json" + + H.copyFile alonzoBabbageTestGenesisJsonSourceFile alonzoBabbageTestGenesisJsonTargetFile + + configurationFile <- H.noteShow $ tempAbsPath "configuration.yaml" + + H.readFile configurationTemplate >>= H.writeFile configurationFile + + H.rewriteYamlFile (tempAbsPath "configuration.yaml") . J.rewriteObject + $ HM.delete "GenesisFile" + . HM.insert "Protocol" (toJSON @String "Cardano") + . HM.insert "PBftSignatureThreshold" (toJSON @Double 0.6) + . HM.insert "minSeverity" (toJSON @String "Debug") + . HM.insert "ByronGenesisFile" (toJSON @String "genesis/byron/genesis.json") + . HM.insert "ShelleyGenesisFile" (toJSON @String "genesis/shelley/genesis.json") + . HM.insert "AlonzoGenesisFile" (toJSON @String "genesis/shelley/genesis.alonzo.json") + . HM.insert "RequiresNetworkMagic" (toJSON @String "RequiresMagic") + . HM.insert "LastKnownBlockVersion-Major" (toJSON @Int 6) + . HM.insert "LastKnownBlockVersion-Minor" (toJSON @Int 0) + . HM.insert "TestShelleyHardForkAtEpoch" (toJSON @Int 0) + . HM.insert "TestAllegraHardForkAtEpoch" (toJSON @Int 0) + . HM.insert "TestMaryHardForkAtEpoch" (toJSON @Int 0) + . HM.insert "TestAlonzoHardForkAtEpoch" (toJSON @Int 0) + . HM.insert "TestBabbageHardForkAtEpoch" (toJSON @Int 0) + . HM.insert "TestEnableDevelopmentHardForkEras" (toJSON True) + . flip HM.alter "setupScribes" + ( fmap + . J.rewriteArrayElements + . J.rewriteObject + . HM.insert "scFormat" + $ case nodeLoggingFormat testnetOptions of + NodeLoggingFormatAsJson -> "ScJson" + NodeLoggingFormatAsText -> "ScText") + + let numPoolNodes = 3 :: Int + + void . H.execCli $ + [ "genesis", "create-staked" + , "--genesis-dir", tempAbsPath + , "--testnet-magic", show @Int testnetMagic + , "--gen-pools", show @Int 3 + , "--supply", "1000000000000" + , "--supply-delegated", "1000000000000" + , "--gen-stake-delegs", "3" + , "--gen-utxo-keys", "3" + ] + + poolKeys <- H.noteShow $ flip fmap [1..numPoolNodes] $ \n -> + PoolNodeKeys + { poolNodeKeysColdVkey = tempAbsPath "pools" "cold" <> show n <> ".vkey" + , poolNodeKeysColdSkey = tempAbsPath "pools" "cold" <> show n <> ".skey" + , poolNodeKeysVrfVkey = tempAbsPath "node-spo" <> show n "vrf.vkey" + , poolNodeKeysVrfSkey = tempAbsPath "node-spo" <> show n "vrf.skey" + , poolNodeKeysStakingVkey = tempAbsPath "pools" "staking-reward" <> show n <> ".vkey" + , poolNodeKeysStakingSkey = tempAbsPath "pools" "staking-reward" <> show n <> ".skey" + } + + wallets <- forM [1..3] $ \idx -> do + pure $ PaymentKeyPair + { paymentSKey = tempAbsPath "utxo-keys/utxo" <> show @Int idx <> ".skey" + , paymentVKey = tempAbsPath "utxo-keys/utxo" <> show @Int idx <> ".vkey" + } + + delegators <- forM [1..3] $ \idx -> do + pure $ Delegator + { paymentKeyPair = PaymentKeyPair + { paymentSKey = tempAbsPath "stake-delegator-keys/payment" <> show @Int idx <> ".skey" + , paymentVKey = tempAbsPath "stake-delegator-keys/payment" <> show @Int idx <> ".vkey" + } + , stakingKeyPair = StakingKeyPair + { stakingSKey = tempAbsPath "stake-delegator-keys/staking" <> show @Int idx <> ".skey" + , stakingVKey = tempAbsPath "stake-delegator-keys/staking" <> show @Int idx <> ".vkey" + } + } + + let spoNodes :: [String] = ("node-spo" <>) . show <$> [1 .. numSpoNodes testnetOptions] + + -- Create the node directories + + forM_ spoNodes $ \node -> do + H.createDirectoryIfMissing (tempAbsPath node) + + -- Here we move all of the keys etc generated by create-staked + -- for the nodes to use + + -- Move all genesis related files + + H.createDirectoryIfMissing $ tempAbsPath "genesis/byron" + H.createDirectoryIfMissing $ tempAbsPath "genesis/shelley" + + files <- H.listDirectory tempAbsPath + forM_ files $ \file -> do + H.note file + + H.renameFile (tempAbsPath "byron-gen-command/genesis.json") (tempAbsPath "genesis/byron/genesis.json") + H.renameFile (tempAbsPath "genesis.alonzo.json") (tempAbsPath "genesis/shelley/genesis.alonzo.json") + H.renameFile (tempAbsPath "genesis.json") (tempAbsPath "genesis/shelley/genesis.json") + + H.rewriteJsonFile (tempAbsPath "genesis/byron/genesis.json") $ J.rewriteObject + $ flip HM.adjust "protocolConsts" + ( J.rewriteObject ( HM.insert "protocolMagic" (toJSON @Int testnetMagic))) + + H.rewriteJsonFile (tempAbsPath "genesis/shelley/genesis.json") $ J.rewriteObject + ( HM.insert "slotLength" (toJSON @Double 0.1) + . HM.insert "activeSlotsCoeff" (toJSON @Double 0.1) + . HM.insert "securityParam" (toJSON @Int 10) + . HM.insert "epochLength" (toJSON @Int 500) + . HM.insert "maxLovelaceSupply" (toJSON @Int 1000000000000) + . HM.insert "minFeeA" (toJSON @Int 44) + . HM.insert "minFeeB" (toJSON @Int 155381) + . HM.insert "minUTxOValue" (toJSON @Int 1000000) + . HM.insert "decentralisationParam" (toJSON @Double 0.7) + . HM.insert "major" (toJSON @Int 7) + . HM.insert "rho" (toJSON @Double 0.1) + . HM.insert "tau" (toJSON @Double 0.1) + . HM.insert "updateQuorum" (toJSON @Int 2) + ) + + H.renameFile (tempAbsPath "pools/vrf1.skey") (tempAbsPath "node-spo1/vrf.skey") + H.renameFile (tempAbsPath "pools/vrf2.skey") (tempAbsPath "node-spo2/vrf.skey") + H.renameFile (tempAbsPath "pools/vrf3.skey") (tempAbsPath "node-spo3/vrf.skey") + + H.renameFile (tempAbsPath "pools/opcert1.cert") (tempAbsPath "node-spo1/opcert.cert") + H.renameFile (tempAbsPath "pools/opcert2.cert") (tempAbsPath "node-spo2/opcert.cert") + H.renameFile (tempAbsPath "pools/opcert3.cert") (tempAbsPath "node-spo3/opcert.cert") + + H.renameFile (tempAbsPath "pools/kes1.skey") (tempAbsPath "node-spo1/kes.skey") + H.renameFile (tempAbsPath "pools/kes2.skey") (tempAbsPath "node-spo2/kes.skey") + H.renameFile (tempAbsPath "pools/kes3.skey") (tempAbsPath "node-spo3/kes.skey") + + -- Byron related + + H.renameFile (tempAbsPath "byron-gen-command/delegate-keys.000.key") (tempAbsPath "node-spo1/byron-delegate.key") + H.renameFile (tempAbsPath "byron-gen-command/delegate-keys.001.key") (tempAbsPath "node-spo2/byron-delegate.key") + H.renameFile (tempAbsPath "byron-gen-command/delegate-keys.002.key") (tempAbsPath "node-spo3/byron-delegate.key") + + H.renameFile (tempAbsPath "byron-gen-command/delegation-cert.000.json") (tempAbsPath "node-spo1/byron-delegation.cert") + H.renameFile (tempAbsPath "byron-gen-command/delegation-cert.001.json") (tempAbsPath "node-spo2/byron-delegation.cert") + H.renameFile (tempAbsPath "byron-gen-command/delegation-cert.002.json") (tempAbsPath "node-spo3/byron-delegation.cert") + + H.writeFile (tempAbsPath "node-spo1/port") "3001" + H.writeFile (tempAbsPath "node-spo2/port") "3002" + H.writeFile (tempAbsPath "node-spo3/port") "3003" + + + -- Make topology files + -- TODO generalise this over the N BFT nodes and pool nodes + + H.lbsWriteFile (tempAbsPath "node-spo1/topology.json") $ encode $ + object + [ "Producers" .= toJSON + [ object + [ "addr" .= toJSON @String "127.0.0.1" + , "port" .= toJSON @Int 3002 + , "valency" .= toJSON @Int 1 + ] + , object + [ "addr" .= toJSON @String "127.0.0.1" + , "port" .= toJSON @Int 3003 + , "valency" .= toJSON @Int 1 + ] + ] + ] + + H.lbsWriteFile (tempAbsPath "node-spo2/topology.json") $ encode $ + object + [ "Producers" .= toJSON + [ object + [ "addr" .= toJSON @String "127.0.0.1" + , "port" .= toJSON @Int 3001 + , "valency" .= toJSON @Int 1 + ] + , object + [ "addr" .= toJSON @String "127.0.0.1" + , "port" .= toJSON @Int 3003 + , "valency" .= toJSON @Int 1 + ] + ] + ] + + H.lbsWriteFile (tempAbsPath "node-spo3/topology.json") $ encode $ + object + [ "Producers" .= toJSON + [ object + [ "addr" .= toJSON @String "127.0.0.1" + , "port" .= toJSON @Int 3001 + , "valency" .= toJSON @Int 1 + ] + , object + [ "addr" .= toJSON @String "127.0.0.1" + , "port" .= toJSON @Int 3002 + , "valency" .= toJSON @Int 1 + ] + ] + ] + + (poolSprockets, poolStdins, poolStdouts, poolStderrs, poolProcessHandles) <- fmap L.unzip5 . forM spoNodes $ \node -> do + dbDir <- H.noteShow $ tempAbsPath "db/" <> node + nodeStdoutFile <- H.noteTempFile logDir $ node <> ".stdout.log" + nodeStderrFile <- H.noteTempFile logDir $ node <> ".stderr.log" + sprocket <- H.noteShow $ Sprocket tempBaseAbsPath (socketDir node) + + H.createDirectoryIfMissing dbDir + H.createDirectoryIfMissing $ tempBaseAbsPath socketDir + + hNodeStdout <- H.openFile nodeStdoutFile IO.WriteMode + hNodeStderr <- H.openFile nodeStderrFile IO.WriteMode + + H.diff (L.length (IO.sprocketArgumentName sprocket)) (<=) IO.maxSprocketArgumentNameLength + + portString <- fmap S.strip . H.readFile $ tempAbsPath node "port" + + (Just stdIn, _, _, hProcess, _) <- H.createProcess =<< + ( H.procNode + [ "run" + , "--config", tempAbsPath "configuration.yaml" + , "--topology", tempAbsPath node "topology.json" + , "--database-path", tempAbsPath node "db" + , "--socket-path", IO.sprocketArgumentName sprocket + , "--shelley-kes-key", tempAbsPath node "kes.skey" + , "--shelley-vrf-key", tempAbsPath node "vrf.skey" + , "--byron-delegation-certificate", tempAbsPath node "byron-delegation.cert" + , "--byron-signing-key", tempAbsPath node "byron-delegate.key" + , "--shelley-operational-certificate", tempAbsPath node "opcert.cert" + , "--port", portString + ] <&> + ( \cp -> cp + { IO.std_in = IO.CreatePipe + , IO.std_out = IO.UseHandle hNodeStdout + , IO.std_err = IO.UseHandle hNodeStderr + , IO.cwd = Just tempBaseAbsPath + } + ) + ) + + when (OS.os `L.elem` ["darwin", "linux"]) $ do + H.onFailure . H.noteIO_ $ IO.readProcess "lsof" ["-iTCP:" <> portString, "-sTCP:LISTEN", "-n", "-P"] "" + + return (sprocket, stdIn, nodeStdoutFile, nodeStderrFile, hProcess) + + now <- H.noteShowIO DTC.getCurrentTime + deadline <- H.noteShow $ DTC.addUTCTime 90 now + + forM_ spoNodes $ \node -> do + nodeStdoutFile <- H.noteTempFile logDir $ node <> ".stdout.log" + H.assertChainExtended deadline (nodeLoggingFormat testnetOptions) nodeStdoutFile + + H.noteShowIO_ DTC.getCurrentTime + + forM_ wallets $ \wallet -> do + H.cat $ paymentSKey wallet + H.cat $ paymentVKey wallet + + return TestnetRuntime + { configurationFile + , shelleyGenesisFile = tempAbsPath "genesis/shelley/genesis.json" + , testnetMagic + , poolNodes = L.zipWith7 PoolNode + spoNodes + poolSprockets + poolStdins + poolStdouts + poolStderrs + poolProcessHandles + poolKeys + , wallets = wallets + , bftNodes = [] + , delegators = delegators + } diff --git a/cardano-testnet/src/Testnet/Cardano.hs b/cardano-testnet/src/Testnet/Cardano.hs index 1a9ca348217..cb8c90d1743 100644 --- a/cardano-testnet/src/Testnet/Cardano.hs +++ b/cardano-testnet/src/Testnet/Cardano.hs @@ -15,41 +15,41 @@ module Testnet.Cardano , Era(..) , TestnetRuntime (..) - , bftSprockets , allNodes , TestnetNode (..) - , Wallet(..) + , PaymentKeyPair(..) , testnet ) where import Control.Applicative (pure) -import Control.Monad (Monad (..), forM_, void, forM, (=<<), when, fmap, return) +import Control.Monad (Monad (..), fmap, forM, forM_, return, void, when, (=<<)) import Control.Monad.IO.Class (liftIO) import Data.Aeson ((.=)) -import Data.Bool (Bool(..)) +import Data.Bool (Bool (..)) import Data.ByteString.Lazy (ByteString) -import Data.Eq (Eq) -import Data.Function (($), (.), flip, id) +import Data.Eq (Eq (..)) +import Data.Function (flip, id, ($), (.)) import Data.Functor ((<$>), (<&>)) import Data.Int (Int) -import Data.List (length, replicate, unzip5, zip, zipWith6, (\\)) -import Data.Maybe (Maybe(Just), fromJust) -import Data.Ord (Ord((<=))) -import Data.Semigroup (Semigroup((<>))) -import Data.String (IsString(fromString), String) +import Data.List ((\\)) +import Data.Maybe (Maybe (Just), fromJust) +import Data.Ord (Ord ((<=))) +import Data.Semigroup (Semigroup ((<>))) +import Data.String (IsString (fromString), String) import GHC.Enum (Bounded, Enum) import GHC.Float (Double) -import GHC.Num (Num((-), (+))) -import GHC.Real (fromIntegral, Integral(div)) +import GHC.Num (Num ((+), (-))) +import GHC.Real (Integral (div), fromIntegral) import Hedgehog.Extras.Stock.IO.Network.Sprocket (Sprocket (..)) import Hedgehog.Extras.Stock.Time (formatIso8601, showUTCTimeSeconds) import Ouroboros.Network.PeerSelection.LedgerPeers (UseLedgerAfter (..)) import Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPoint (..)) import System.FilePath.Posix (()) -import System.IO (FilePath) +import Test.Runtime (NodeLoggingFormat (..), PaymentKeyPair (..), PoolNode (PoolNode), + PoolNodeKeys (..), TestnetNode (..), TestnetRuntime (..)) import Text.Read (Read) -import Text.Show (Show(show)) +import Text.Show (Show (show)) import qualified Cardano.Node.Configuration.Topology as NonP2P import qualified Cardano.Node.Configuration.TopologyP2P as P2P @@ -60,7 +60,6 @@ import qualified Data.Map as M import qualified Data.Time.Clock as DTC import qualified Hedgehog as H import qualified Hedgehog.Extras.Stock.Aeson as J -import qualified Hedgehog.Extras.Stock.IO.File as IO import qualified Hedgehog.Extras.Stock.IO.Network.Socket as IO import qualified Hedgehog.Extras.Stock.IO.Network.Sprocket as IO import qualified Hedgehog.Extras.Stock.OS as OS @@ -74,7 +73,9 @@ import qualified System.Directory as IO import qualified System.Info as OS import qualified System.IO as IO import qualified System.Process as IO +import qualified Test.Assert as H import qualified Test.Process as H +import qualified Test.Runtime as TR import qualified Testnet.Conf as H {- HLINT ignore "Reduce duplication" -} @@ -100,17 +101,19 @@ data TestnetOptions = TestnetOptions , slotLength :: Double , activeSlotsCoeff :: Double , enableP2P :: Bool + , nodeLoggingFormat :: NodeLoggingFormat } deriving (Eq, Show) defaultTestnetOptions :: TestnetOptions defaultTestnetOptions = TestnetOptions - { bftNodeOptions = replicate 2 defaultTestnetNodeOptions + { bftNodeOptions = L.replicate 2 defaultTestnetNodeOptions , numPoolNodes = 1 , era = Alonzo , epochLength = 1500 , slotLength = 0.2 , activeSlotsCoeff = 0.2 , enableP2P = False + , nodeLoggingFormat = NodeLoggingFormatAsText } newtype TestnetNodeOptions = TestnetNodeOptions @@ -124,33 +127,8 @@ defaultTestnetNodeOptions = TestnetNodeOptions { extraNodeCliArgs = [] } -data TestnetRuntime = TestnetRuntime - { configurationFile :: FilePath - , testnetMagic :: Int - , bftNodes :: [TestnetNode] - , poolNodes :: [TestnetNode] - , wallets :: [Wallet] - } - -bftSprockets :: TestnetRuntime -> [Sprocket] -bftSprockets = fmap nodeSprocket . bftNodes - allNodes :: TestnetRuntime -> [TestnetNode] -allNodes tr = bftNodes tr <> poolNodes tr - -data TestnetNode = TestnetNode - { nodeName :: String - , nodeSprocket :: Sprocket - , nodeStdinHandle :: IO.Handle - , nodeStdout :: FilePath - , nodeStderr :: FilePath - , nodeProcessHandle :: IO.ProcessHandle - } - -data Wallet = Wallet - { paymentVKey :: FilePath - , paymentSKey :: FilePath - } deriving (Eq, Show) +allNodes tr = bftNodes tr <> fmap TR.poolNodeToTestnetNode (poolNodes tr) ifaceAddress :: String ifaceAddress = "127.0.0.1" @@ -197,14 +175,13 @@ mkTopologyConfig numNodes allPorts port True = J.encode topologyP2P [] (P2P.UseLedger DontUseLedger) - testnet :: TestnetOptions -> H.Conf -> H.Integration TestnetRuntime testnet testnetOptions H.Conf {..} = do void $ H.note OS.os currentTime <- H.noteShowIO DTC.getCurrentTime startTime <- H.noteShow $ DTC.addUTCTime startTimeOffsetSeconds currentTime configurationFile <- H.noteShow $ tempAbsPath "configuration.yaml" - let numBftNodes = length (bftNodeOptions testnetOptions) + let numBftNodes = L.length (bftNodeOptions testnetOptions) bftNodesN = [1 .. numBftNodes] poolNodesN = [1 .. numPoolNodes testnetOptions] bftNodeNames = ("node-bft" <>) . show @Int <$> bftNodesN @@ -270,8 +247,15 @@ testnet testnetOptions H.Conf {..} = do . HM.insert "TraceBlockchainTime" (J.toJSON True) . HM.delete "GenesisFile" . HM.insert "TestEnableDevelopmentHardForkEras" (J.toJSON @Bool True) - . HM.insert "TestEnableDevelopmentNetworkProtocols" (J.toJSON @Bool True) . HM.insert "EnableP2P" (J.toJSON @Bool (enableP2P testnetOptions)) + . flip HM.alter "setupScribes" + ( fmap + . J.rewriteArrayElements + . J.rewriteObject + . HM.insert "scFormat" + $ case nodeLoggingFormat testnetOptions of + NodeLoggingFormatAsJson -> "ScJson" + NodeLoggingFormatAsText -> "ScText") . forkOptions forM_ allNodeNames $ \node -> do @@ -492,7 +476,10 @@ testnet testnetOptions H.Conf {..} = do -- Make the pool operator cold keys -- This was done already for the BFT nodes as part of the genesis creation - forM_ poolNodeNames $ \node -> do + + poolKeys <- forM poolNodesN $ \i -> do + let node = "node-pool" <> show @Int i + void $ H.execCli [ "node", "key-gen" , "--cold-verification-key-file", tempAbsPath node "shelley/operator.vkey" @@ -500,12 +487,28 @@ testnet testnetOptions H.Conf {..} = do , "--operational-certificate-issue-counter-file", tempAbsPath node "shelley/operator.counter" ] + poolNodeKeysColdVkey <- H.note $ tempAbsPath "node-pool" <> show i <> "/shelley/operator.vkey" + poolNodeKeysColdSkey <- H.note $ tempAbsPath "node-pool" <> show i <> "/shelley/operator.skey" + poolNodeKeysVrfVkey <- H.note $ tempAbsPath node "shelley/vrf.vkey" + poolNodeKeysVrfSkey <- H.note $ tempAbsPath node "shelley/vrf.skey" + poolNodeKeysStakingVkey <- H.note $ tempAbsPath node "shelley/staking.vkey" + poolNodeKeysStakingSkey <- H.note $ tempAbsPath node "shelley/staking.skey" + void $ H.execCli [ "node", "key-gen-VRF" - , "--verification-key-file", tempAbsPath node "shelley/vrf.vkey" - , "--signing-key-file", tempAbsPath node "shelley/vrf.skey" + , "--verification-key-file", poolNodeKeysVrfVkey + , "--signing-key-file", poolNodeKeysVrfSkey ] + return PoolNodeKeys + { TR.poolNodeKeysColdVkey + , TR.poolNodeKeysColdSkey + , TR.poolNodeKeysVrfVkey + , TR.poolNodeKeysVrfSkey + , TR.poolNodeKeysStakingVkey + , TR.poolNodeKeysStakingSkey + } + -- Symlink the BFT operator keys from the genesis delegates, for uniformity forM_ bftNodesN $ \n -> do H.createFileLink (tempAbsPath "shelley/delegate-keys/delegate" <> show @Int n <> ".skey") (tempAbsPath "node-bft" <> show @Int n "shelley/operator.skey") @@ -605,7 +608,7 @@ testnet testnetOptions H.Conf {..} = do , "--out-file", tempAbsPath "addresses/" <> addr <> "-stake.reg.cert" ] - pure $ Wallet + pure $ PaymentKeyPair { paymentSKey , paymentVKey } @@ -732,8 +735,8 @@ testnet testnetOptions H.Conf {..} = do -------------------------------- -- Launch cluster of three nodes - let bftNodeNameAndOpts = zip bftNodeNames (bftNodeOptions testnetOptions) - (bftSprockets', bftStdins, bftStdouts, bftStderrs, bftProcessHandles) <- fmap unzip5 . forM bftNodeNameAndOpts $ \(node, nodeOpts) -> do + let bftNodeNameAndOpts = L.zip bftNodeNames (bftNodeOptions testnetOptions) + (bftSprockets', bftStdins, bftStdouts, bftStderrs, bftProcessHandles) <- fmap L.unzip5 . forM bftNodeNameAndOpts $ \(node, nodeOpts) -> do dbDir <- H.noteShow $ tempAbsPath "db/" <> node nodeStdoutFile <- H.noteTempFile logDir $ node <> ".stdout.log" nodeStderrFile <- H.noteTempFile logDir $ node <> ".stderr.log" @@ -781,7 +784,7 @@ testnet testnetOptions H.Conf {..} = do H.threadDelay 100000 - (poolSprockets, poolStdins, poolStdouts, poolStderrs, poolProcessHandles) <- fmap unzip5 . forM poolNodeNames $ \node -> do + (poolSprockets, poolStdins, poolStdouts, poolStderrs, poolProcessHandles) <- fmap L.unzip5 . forM poolNodeNames $ \node -> do dbDir <- H.noteShow $ tempAbsPath "db/" <> node nodeStdoutFile <- H.noteTempFile logDir $ node <> ".stdout.log" nodeStderrFile <- H.noteTempFile logDir $ node <> ".stderr.log" @@ -834,27 +837,29 @@ testnet testnetOptions H.Conf {..} = do forM_ allNodeNames $ \node -> do nodeStdoutFile <- H.noteTempFile logDir $ node <> ".stdout.log" - H.assertByDeadlineIOCustom "stdout does not contain \"until genesis start time\"" deadline $ IO.fileContains "until genesis start time at" nodeStdoutFile - H.assertByDeadlineIOCustom "stdout does not contain \"Chain extended\"" deadline $ IO.fileContains "Chain extended, new tip" nodeStdoutFile + H.assertChainExtended deadline (nodeLoggingFormat testnetOptions) nodeStdoutFile H.noteShowIO_ DTC.getCurrentTime return TestnetRuntime { configurationFile + , shelleyGenesisFile = tempAbsPath "shelley/genesis.json" , testnetMagic - , bftNodes = zipWith6 TestnetNode + , bftNodes = L.zipWith6 TestnetNode bftNodeNames bftSprockets' bftStdins bftStdouts bftStderrs bftProcessHandles - , poolNodes = zipWith6 TestnetNode + , poolNodes = L.zipWith7 PoolNode poolNodeNames poolSprockets poolStdins poolStdouts poolStderrs poolProcessHandles + poolKeys , wallets + , delegators = [] -- TODO this should be populated } diff --git a/cardano-testnet/test/Main.hs b/cardano-testnet/test/Main.hs index 690d75ae294..32e302b09f4 100644 --- a/cardano-testnet/test/Main.hs +++ b/cardano-testnet/test/Main.hs @@ -5,11 +5,14 @@ module Main ) where import Prelude --- import qualified Spec.Cli.KesPeriodInfo +import Test.Tasty (TestTree) + +import qualified Spec.Cli.Alonzo.LeadershipSchedule +import qualified Spec.Cli.Babbage.LeadershipSchedule +import qualified Spec.Cli.KesPeriodInfo import qualified Spec.Node.Shutdown import qualified Spec.ShutdownOnSlotSynced import qualified System.Environment as E -import Test.Tasty (TestTree) import qualified Test.Tasty as T import qualified Test.Tasty.Ingredients as T import qualified Test.Util as H @@ -19,10 +22,16 @@ tests = pure $ T.testGroup "test/Spec.hs" [ T.testGroup "Spec" [ H.ignoreOnWindows "Shutdown" Spec.Node.Shutdown.hprop_shutdown , H.ignoreOnWindows "ShutdownOnSlotSynced" Spec.ShutdownOnSlotSynced.hprop_shutdownOnSlotSynced + , T.testGroup "Alonzo" + [ H.ignoreOnMacAndWindows "leadership-schedule" Spec.Cli.Alonzo.LeadershipSchedule.hprop_leadershipSchedule + ] + , T.testGroup "Babbage" + [ H.ignoreOnMacAndWindows "leadership-schedule" Spec.Cli.Babbage.LeadershipSchedule.hprop_leadershipSchedule + ] -- Ignored on Windows due to : commitBuffer: invalid argument (invalid character) -- as a result of the kes-period-info output to stdout. -- TODO: Babbage temporarily ignored due to broken protocol-state query - -- H.ignoreOnWindows "kes-period-info" Spec.Cli.KesPeriodInfo.hprop_kes_period_info + , H.disabled "kes-period-info" Spec.Cli.KesPeriodInfo.hprop_kes_period_info ] ] diff --git a/cardano-testnet/test/Spec/Cli/Alonzo/LeadershipSchedule.hs b/cardano-testnet/test/Spec/Cli/Alonzo/LeadershipSchedule.hs new file mode 100644 index 00000000000..f8535d22b9b --- /dev/null +++ b/cardano-testnet/test/Spec/Cli/Alonzo/LeadershipSchedule.hs @@ -0,0 +1,516 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{- HLINT ignore "Redundant return" -} +{- HLINT ignore "Use let" -} + +module Spec.Cli.Alonzo.LeadershipSchedule + ( hprop_leadershipSchedule + ) where + +import Cardano.Api (AlonzoEra, SerialiseAddress (serialiseAddress), UTxO (UTxO)) +import qualified Cardano.Api as Api +import Cardano.Api.Shelley (PoolId) +import Cardano.CLI.Shelley.Output (QueryTipLocalStateOutput (mEpoch)) +import Cardano.CLI.Shelley.Run.Query (DelegationsAndRewards, mergeDelegsAndRewards) +import Control.Monad (void) +import qualified Data.Aeson.Types as J +import Data.List ((\\)) +import qualified Data.List as L +import qualified Data.Map.Strict as Map +import Data.Monoid (Last (..)) +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Data.Time.Clock as DTC +import GHC.Stack (callStack) +import Hedgehog (Property, (===)) +import qualified Hedgehog as H +import qualified Hedgehog.Extras.Stock.IO.Network.Sprocket as IO +import qualified Hedgehog.Extras.Test.Base as H +import qualified Hedgehog.Extras.Test.Concurrent as H +import qualified Hedgehog.Extras.Test.File as H +import qualified Hedgehog.Extras.Test.Process as H +import Prelude +import qualified System.Directory as IO +import System.Environment (getEnvironment) +import System.FilePath (()) +import qualified System.Info as SYS +import qualified Test.Assert as H +import qualified Test.Base as H +import qualified Test.Process as H +import qualified Test.Runtime as TR +import Test.Runtime (LeadershipSlot (..)) +import qualified Testnet.Cardano as TC +import Testnet.Cardano (TestnetOptions (..), TestnetRuntime (..)) +import qualified Testnet.Conf as H +import Testnet.Utils (waitUntilEpoch) + +hprop_leadershipSchedule :: Property +hprop_leadershipSchedule = H.integration . H.runFinallies . H.workspace "alonzo" $ \tempAbsBasePath' -> do + H.note_ SYS.os + base <- H.note =<< H.noteIO . IO.canonicalizePath =<< H.getProjectBase + configurationTemplate <- H.noteShow $ base "configuration/defaults/byron-mainnet/configuration.yaml" + conf@H.Conf { H.tempBaseAbsPath, H.tempAbsPath } <- H.noteShowM $ + H.mkConf (H.ProjectBase base) (H.YamlFilePath configurationTemplate) tempAbsBasePath' Nothing + + fastTestnetOptions <- pure TC.defaultTestnetOptions + { epochLength = 500 + , slotLength = 0.01 + , activeSlotsCoeff = 0.1 + , nodeLoggingFormat = TR.NodeLoggingFormatAsJson + } + tr@TC.TestnetRuntime + { testnetMagic + , poolNodes + } <- TC.testnet fastTestnetOptions conf + + poolNode1 <- H.headM poolNodes + + env <- H.evalIO getEnvironment + + execConfig <- H.noteShow H.ExecConfig + { H.execConfigEnv = Last $ Just $ + [ ("CARDANO_NODE_SOCKET_PATH", IO.sprocketArgumentName $ head $ TR.bftSprockets tr) + ] + -- The environment must be passed onto child process on Windows in order to + -- successfully start that process. + <> env + , H.execConfigCwd = Last $ Just tempBaseAbsPath + } + + -- First we note all the relevant files + H.note_ base + work <- H.note tempAbsPath + + -- We get our UTxOs from here + utxoVKeyFile <- H.note $ tempAbsPath "shelley/utxo-keys/utxo1.vkey" + utxoSKeyFile <- H.note $ tempAbsPath "shelley/utxo-keys/utxo1.skey" + utxoVKeyFile2 <- H.note $ tempAbsPath "shelley/utxo-keys/utxo2.vkey" + utxoSKeyFile2 <- H.note $ tempAbsPath "shelley/utxo-keys/utxo2.skey" + + utxoAddr <- H.execCli + [ "address", "build" + , "--testnet-magic", show @Int testnetMagic + , "--payment-verification-key-file", utxoVKeyFile + ] + + void $ H.execCli' execConfig + [ "query", "utxo" + , "--address", utxoAddr + , "--cardano-mode" + , "--testnet-magic", show @Int testnetMagic + , "--out-file", work "utxo-1.json" + ] + + H.cat $ work "utxo-1.json" + + utxo1Json <- H.leftFailM . H.readJsonFile $ work "utxo-1.json" + UTxO utxo1 <- H.noteShowM $ H.jsonErrorFail $ J.fromJSON @(UTxO AlonzoEra) utxo1Json + txin <- H.noteShow $ head $ Map.keys utxo1 + + -- Staking keys + utxoStakingVkey2 <- H.note $ tempAbsPath "shelley/utxo-keys/utxo2-stake.vkey" + utxoStakingSkey2 <- H.note $ tempAbsPath "shelley/utxo-keys/utxo2-stake.skey" + + utxoaddrwithstaking <- H.execCli + [ "address", "build" + , "--payment-verification-key-file", utxoVKeyFile2 + , "--stake-verification-key-file", utxoStakingVkey2 + , "--testnet-magic", show @Int testnetMagic + ] + + utxostakingaddr <- filter (/= '\n') <$> H.execCli + [ "stake-address", "build" + , "--stake-verification-key-file", utxoStakingVkey2 + , "--testnet-magic", show @Int testnetMagic + ] + + -- Stake pool related + H.createDirectoryIfMissing $ tempAbsPath "addresses" + poolownerstakekey <- H.note $ tempAbsPath "addresses/pool-owner1-stake.vkey" + poolownerverkey <- H.note $ tempAbsPath "addresses/pool-owner1.vkey" + poolownerstakeaddr <- filter (/= '\n') <$> H.execCli + [ "stake-address", "build" + , "--stake-verification-key-file", poolownerstakekey + , "--testnet-magic", show @Int testnetMagic + ] + + poolowneraddresswstakecred <- H.execCli + [ "address", "build" + , "--payment-verification-key-file", poolownerverkey + , "--stake-verification-key-file", poolownerstakekey + , "--testnet-magic", show @Int testnetMagic + ] + + poolcoldVkey <- H.note $ tempAbsPath "node-pool1/shelley/operator.vkey" + poolcoldSkey <- H.note $ tempAbsPath "node-pool1/shelley/operator.skey" + + stakePoolId <- filter ( /= '\n') <$> H.execCli + [ "stake-pool", "id" + , "--cold-verification-key-file", poolcoldVkey + ] + + -- REGISTER PLEDGER POOL + + -- Create pledger registration certificate + void $ H.execCli + [ "stake-address", "registration-certificate" + , "--stake-verification-key-file", poolownerstakekey + , "--out-file", work "pledger.regcert" + ] + + void $ H.execCli' execConfig + [ "transaction", "build" + , "--alonzo-era" + , "--testnet-magic", show @Int testnetMagic + , "--change-address", utxoAddr + , "--tx-in", T.unpack $ Api.renderTxIn txin + , "--tx-out", poolowneraddresswstakecred <> "+" <> show @Int 5000000 + , "--tx-out", utxoaddrwithstaking <> "+" <> show @Int 5000000 + , "--witness-override", show @Int 3 + , "--certificate-file", work "pledger.regcert" + , "--out-file", work "pledge-registration-cert.txbody" + ] + + void $ H.execCli + [ "transaction", "sign" + , "--tx-body-file", work "pledge-registration-cert.txbody" + , "--testnet-magic", show @Int testnetMagic + , "--signing-key-file", utxoSKeyFile + , "--out-file", work "pledge-registration-cert.tx" + ] + + H.note_ "Submitting pool owner/pledge stake registration cert and funding stake pool owner address..." + + void $ H.execCli' execConfig + [ "transaction", "submit" + , "--tx-file", work "pledge-registration-cert.tx" + , "--testnet-magic", show @Int testnetMagic + ] + + -- Things take long on non-linux machines + if H.isLinux + then H.threadDelay 5000000 + else H.threadDelay 10000000 + + -- Check to see if pledge's stake address was registered + + void $ H.execCli' execConfig + [ "query", "stake-address-info" + , "--address", poolownerstakeaddr + , "--testnet-magic", show @Int testnetMagic + , "--out-file", work "pledgeownerregistration.json" + ] + + pledgerStakeInfo <- H.leftFailM . H.readJsonFile $ work "pledgeownerregistration.json" + delegsAndRewardsMap <- H.noteShowM $ H.jsonErrorFail $ J.fromJSON @DelegationsAndRewards pledgerStakeInfo + let delegsAndRewards = mergeDelegsAndRewards delegsAndRewardsMap + + length delegsAndRewards === 1 + + let (pledgerSAddr, _rewards, _poolId) = head delegsAndRewards + + -- Pledger and owner are and can be the same + T.unpack (serialiseAddress pledgerSAddr) === poolownerstakeaddr + + H.note_ $ "Register staking key: " <> show utxoStakingVkey2 + + void $ H.execCli' execConfig + [ "query", "utxo" + , "--address", utxoaddrwithstaking + , "--cardano-mode" + , "--testnet-magic", show @Int testnetMagic + , "--out-file", work "utxo-addr-with-staking-1.json" + ] + + H.cat $ work "utxo-addr-with-staking-1.json" + + utxoWithStaking1Json <- H.leftFailM . H.readJsonFile $ work "utxo-addr-with-staking-1.json" + UTxO utxoWithStaking1 <- H.noteShowM $ H.jsonErrorFail $ J.fromJSON @(UTxO AlonzoEra) utxoWithStaking1Json + txinForStakeReg <- H.noteShow $ head $ Map.keys utxoWithStaking1 + + void $ H.execCli + [ "stake-address", "registration-certificate" + , "--stake-verification-key-file", utxoStakingVkey2 + , "--out-file", work "stakekey.regcert" + ] + + void $ H.execCli' execConfig + [ "transaction", "build" + , "--alonzo-era" + , "--testnet-magic", show @Int testnetMagic + , "--change-address", utxoaddrwithstaking + , "--tx-in", T.unpack (Api.renderTxIn txinForStakeReg) + , "--tx-out", utxoaddrwithstaking <> "+" <> show @Int 1000000 + , "--witness-override", show @Int 3 + , "--certificate-file", work "stakekey.regcert" + , "--out-file", work "key-registration-cert.txbody" + ] + + void $ H.execCli + [ "transaction", "sign" + , "--tx-body-file", work "key-registration-cert.txbody" + , "--testnet-magic", show @Int testnetMagic + , "--signing-key-file", utxoStakingSkey2 + , "--signing-key-file", utxoSKeyFile2 + , "--out-file", work "key-registration-cert.tx" + ] + + void $ H.execCli' execConfig + [ "transaction", "submit" + , "--tx-file", work "key-registration-cert.tx" + , "--testnet-magic", show @Int testnetMagic + ] + + H.note_ $ "Check to see if " <> utxoStakingVkey2 <> " was registered..." + H.threadDelay 10000000 + + void $ H.execCli' execConfig + [ "query", "stake-address-info" + , "--address", utxostakingaddr + , "--testnet-magic", show @Int testnetMagic + , "--out-file", work "stake-address-info-utxo-staking-vkey-2.json" + ] + + userStakeAddrInfoJSON <- H.leftFailM . H.readJsonFile $ work "stake-address-info-utxo-staking-vkey-2.json" + delegsAndRewardsMapUser <- H.noteShowM $ H.jsonErrorFail $ J.fromJSON @DelegationsAndRewards userStakeAddrInfoJSON + let delegsAndRewardsUser = mergeDelegsAndRewards delegsAndRewardsMapUser + userStakeAddrInfo = filter (\(sAddr,_,_) -> utxostakingaddr == T.unpack (serialiseAddress sAddr)) delegsAndRewardsUser + (userSAddr, _rewards, _poolId) = head userStakeAddrInfo + + + H.note_ $ "Check staking key: " <> show utxoStakingVkey2 <> " was registered" + T.unpack (serialiseAddress userSAddr) === utxostakingaddr + + H.note_ "Get updated UTxO" + + void $ H.execCli' execConfig + [ "query", "utxo" + , "--address", utxoAddr + , "--cardano-mode" + , "--testnet-magic", show @Int testnetMagic + , "--out-file", work "utxo-2.json" + ] + + H.cat $ work "utxo-2.json" + + utxo2Json <- H.leftFailM . H.readJsonFile $ work "utxo-2.json" + UTxO utxo2 <- H.noteShowM $ H.jsonErrorFail $ J.fromJSON @(UTxO AlonzoEra) utxo2Json + txin2 <- H.noteShow $ head $ Map.keys utxo2 + + H.note_ "Create delegation certificate of pledger" + + void $ H.execCli + [ "stake-address", "delegation-certificate" + , "--stake-verification-key-file", poolownerstakekey + , "--cold-verification-key-file", poolcoldVkey + , "--out-file", work "pledger.delegcert" + ] + + H.note_ "Register stake pool and delegate pledger to stake pool in a single tx" + + void $ H.execCli' execConfig + [ "transaction", "build" + , "--alonzo-era" + , "--testnet-magic", show @Int testnetMagic + , "--change-address", utxoAddr + , "--tx-in", T.unpack $ Api.renderTxIn txin2 + , "--tx-out", utxoAddr <> "+" <> show @Int 10000000 + , "--witness-override", show @Int 3 + , "--certificate-file", tempAbsPath "node-pool1/registration.cert" + , "--certificate-file", work "pledger.delegcert" + , "--out-file", work "register-stake-pool.txbody" + ] + + void $ H.execCli + [ "transaction", "sign" + , "--tx-body-file", work "register-stake-pool.txbody" + , "--testnet-magic", show @Int testnetMagic + , "--signing-key-file", utxoSKeyFile + , "--signing-key-file", poolcoldSkey + , "--signing-key-file", tempAbsPath "node-pool1/owner.skey" + , "--out-file", work "register-stake-pool.tx" + ] + + void $ H.execCli' execConfig + [ "transaction", "submit" + , "--tx-file", work "register-stake-pool.tx" + , "--testnet-magic", show @Int testnetMagic + ] + + if H.isLinux + then H.threadDelay 5000000 + else H.threadDelay 20000000 + + void $ H.execCli' execConfig + [ "query", "stake-pools" + , "--testnet-magic", show @Int testnetMagic + , "--out-file", work "current-registered.pools.json" + ] + + currRegPools <- H.leftFailM . H.readJsonFile $ work "current-registered.pools.json" + poolIds <- H.noteShowM $ H.jsonErrorFail $ J.fromJSON @(Set PoolId) currRegPools + poolId <- H.noteShow $ head $ Set.toList poolIds + + H.note_ "Check stake pool was successfully registered" + T.unpack (Api.serialiseToBech32 poolId) === stakePoolId + + H.note_ "Check pledge was successfully delegated" + void $ H.execCli' execConfig + [ "query", "stake-address-info" + , "--address", poolownerstakeaddr + , "--testnet-magic", show @Int testnetMagic + , "--out-file", work "pledge-stake-address-info.json" + ] + + pledgeStakeAddrInfoJSON <- H.leftFailM . H.readJsonFile $ work "pledge-stake-address-info.json" + delegsAndRewardsMapPledge <- H.noteShowM $ H.jsonErrorFail $ J.fromJSON @DelegationsAndRewards pledgeStakeAddrInfoJSON + let delegsAndRewardsPledge = mergeDelegsAndRewards delegsAndRewardsMapPledge + pledgeStakeAddrInfo = filter (\(sAddr,_,_) -> poolownerstakeaddr == T.unpack (serialiseAddress sAddr)) delegsAndRewardsPledge + (pledgeSAddr, _rewards, pledgerDelegPoolId) = head pledgeStakeAddrInfo + + H.note_ "Check pledge has been delegated to pool" + case pledgerDelegPoolId of + Nothing -> H.failMessage callStack "Pledge was not delegated to pool" + Just pledgerDelagator -> T.unpack (Api.serialiseToBech32 pledgerDelagator) === stakePoolId + T.unpack (serialiseAddress pledgeSAddr) === poolownerstakeaddr + + H.note_ "Get updated UTxO" + + void $ H.execCli' execConfig + [ "query", "utxo" + , "--address", utxoAddr + , "--cardano-mode" + , "--testnet-magic", show @Int testnetMagic + , "--out-file", work "utxo-3.json" + ] + + H.threadDelay 10000000 + + H.note_ "Get updated UTxO" + + void $ H.execCli' execConfig + [ "query", "utxo" + , "--address", utxoAddr + , "--cardano-mode" + , "--testnet-magic", show @Int testnetMagic + , "--out-file", work "utxo-4.json" + ] + + H.cat $ work "utxo-4.json" + + -- Wait 5 seconds + H.threadDelay 5000000 + + H.note_ "Wait for rewards to be paid out. This will be current epoch + 4" + + void $ H.execCli' execConfig + [ "query", "tip" + , "--testnet-magic", show @Int testnetMagic + , "--out-file", work "current-tip.json" + ] + + tipJSON <- H.leftFailM . H.readJsonFile $ work "current-tip.json" + tip <- H.noteShowM $ H.jsonErrorFail $ J.fromJSON @QueryTipLocalStateOutput tipJSON + currEpoch <- + case mEpoch tip of + Nothing -> + H.failMessage callStack "cardano-cli query tip returned Nothing for EpochNo" + Just currEpoch -> return currEpoch + + let rewardsEpoch = currEpoch + 4 + + waitedEpoch <- waitUntilEpoch + (work "current-tip.json") + testnetMagic + execConfig + rewardsEpoch + + H.note_ "Check we have reached 4 epochs ahead" + waitedEpoch === rewardsEpoch + + void $ H.execCli' execConfig + [ "query", "tip" + , "--testnet-magic", show @Int testnetMagic + , "--out-file", work "current-tip-2.json" + ] + + tip2JSON <- H.leftFailM . H.readJsonFile $ work "current-tip-2.json" + tip2 <- H.noteShowM $ H.jsonErrorFail $ J.fromJSON @QueryTipLocalStateOutput tip2JSON + + currEpoch2 <- case mEpoch tip2 of + Nothing -> H.failMessage callStack "cardano-cli query tip returned Nothing for EpochNo" + Just currEpoch2 -> return currEpoch2 + + H.note_ $ "Current Epoch: " <> show currEpoch2 + + now <- H.noteShowIO DTC.getCurrentTime + deadline <- H.noteShow $ DTC.addUTCTime 90 now + + H.assertByDeadlineMCustom "stdout does not contain \"until genesis start time\"" deadline $ do + H.threadDelay 1000000 + void $ H.execCli' execConfig + [ "query", "tip" + , "--testnet-magic", show @Int testnetMagic + , "--out-file", work "current-tip-3.json" + ] + + tip3JSON <- H.leftFailM . H.readJsonFile $ work "current-tip-3.json" + tip3 <- H.noteShowM $ H.jsonErrorFail $ J.fromJSON @QueryTipLocalStateOutput tip3JSON + + currEpoch3 <- case mEpoch tip3 of + Nothing -> H.failMessage callStack "cardano-cli query tip returned Nothing for EpochNo" + Just currEpoch3 -> return currEpoch3 + + H.note_ $ "Current Epoch: " <> show currEpoch3 + return (currEpoch3 > currEpoch2 + 1) + + ledgerStateJson <- H.execCli' execConfig + [ "query", "ledger-state" + , "--cardano-mode" + , "--testnet-magic", show @Int testnetMagic + ] + + H.note_ ledgerStateJson + + H.note_ "Done" + + let poolVrfSkey = TR.poolNodeKeysVrfSkey $ TR.poolNodeKeys poolNode1 + scheduleFile <- H.noteTempFile tempAbsPath "schedule.log" + + void $ H.execCli' execConfig + [ "query", "leadership-schedule" + , "--testnet-magic", show @Int testnetMagic + , "--genesis", TC.shelleyGenesisFile tr + , "--stake-pool-id", stakePoolId + , "--vrf-signing-key-file", poolVrfSkey + , "--out-file", scheduleFile + , "--current" + ] + + scheduleJson <- H.leftFailM $ H.readJsonFile scheduleFile + + expectedLeadershipSlotNumbers <- H.noteShowM $ fmap (fmap slotNumber) $ H.leftFail $ J.parseEither (J.parseJSON @[LeadershipSlot]) scheduleJson + + H.assert $ not (L.null expectedLeadershipSlotNumbers) + + leadershipDeadline <- H.noteShowM $ DTC.addUTCTime 90 <$> H.noteShowIO DTC.getCurrentTime + + H.assertByDeadlineMCustom "Leader schedule is correct" leadershipDeadline $ do + leaderSlots <- H.getRelevantLeaderSlots (TR.poolNodeStdout poolNode1) (minimum expectedLeadershipSlotNumbers) + maxSlotExpected <- H.noteShow $ maximum expectedLeadershipSlotNumbers + maxActualSlot <- H.noteShow $ maximum leaderSlots + return $ maxActualSlot >= maxSlotExpected + + leaderSlots <- H.getRelevantLeaderSlots (TR.poolNodeStdout poolNode1) (minimum expectedLeadershipSlotNumbers) + + -- It's possible for some slots to not be assigned in TPraos when BFT nodes are running. + -- TODO Remove BFT nodes from testnet and assert the schedule is equal to actual slots + H.assert $ L.length (expectedLeadershipSlotNumbers \\ leaderSlots) <= 1 diff --git a/cardano-testnet/test/Spec/Cli/Babbage/LeadershipSchedule.hs b/cardano-testnet/test/Spec/Cli/Babbage/LeadershipSchedule.hs new file mode 100644 index 00000000000..2efe4e4d6bb --- /dev/null +++ b/cardano-testnet/test/Spec/Cli/Babbage/LeadershipSchedule.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{- HLINT ignore "Redundant id" -} +{- HLINT ignore "Redundant return" -} +{- HLINT ignore "Use head" -} +{- HLINT ignore "Use let" -} + +module Spec.Cli.Babbage.LeadershipSchedule + ( hprop_leadershipSchedule + ) where + +import Cardano.CLI.Shelley.Output (QueryTipLocalStateOutput (..)) +import Control.Monad (void) +import Data.List ((\\)) +import Data.Monoid (Last (..)) +import GHC.Stack (callStack) +import Hedgehog (Property) +import Prelude +import System.Environment (getEnvironment) +import System.FilePath (()) +import Testnet.Babbage (TestnetOptions (..), TestnetRuntime (..)) + +import qualified Data.Aeson as J +import qualified Data.Aeson.Types as J +import qualified Data.List as L +import qualified Data.Time.Clock as DTC +import qualified Hedgehog as H +import qualified Hedgehog.Extras.Stock.IO.Network.Sprocket as IO +import qualified Hedgehog.Extras.Test.Base as H +import qualified Hedgehog.Extras.Test.Concurrent as H +import qualified Hedgehog.Extras.Test.File as H +import qualified Hedgehog.Extras.Test.Process as H +import qualified System.Directory as IO +import qualified System.Info as SYS +import qualified Test.Assert as H +import qualified Test.Base as H +import qualified Test.Process as H +import qualified Test.Runtime as TR +import Test.Runtime (LeadershipSlot (..)) +import qualified Testnet.Babbage as TC +import qualified Testnet.Conf as H + +hprop_leadershipSchedule :: Property +hprop_leadershipSchedule = H.integration . H.runFinallies . H.workspace "alonzo" $ \tempAbsBasePath' -> do + H.note_ SYS.os + base <- H.note =<< H.noteIO . IO.canonicalizePath =<< H.getProjectBase + configurationTemplate <- H.noteShow $ base "configuration/defaults/byron-mainnet/configuration.yaml" + conf@H.Conf { H.tempBaseAbsPath, H.tempAbsPath } <- H.noteShowM $ + H.mkConf (H.ProjectBase base) (H.YamlFilePath configurationTemplate) tempAbsBasePath' Nothing + + work <- H.note $ tempAbsPath "work" + H.createDirectoryIfMissing work + + testnetOptions <- pure TC.defaultTestnetOptions + { nodeLoggingFormat = TR.NodeLoggingFormatAsJson + } + tr@TC.TestnetRuntime + { testnetMagic + , poolNodes + -- , wallets + -- , delegators + } <- TC.testnet testnetOptions conf + + poolNode1 <- H.headM poolNodes + + env <- H.evalIO getEnvironment + + poolSprocket1 <- H.noteShow $ TR.poolNodeSprocket poolNode1 + + execConfig <- H.noteShow H.ExecConfig + { H.execConfigEnv = Last $ Just $ + [ ("CARDANO_NODE_SOCKET_PATH", IO.sprocketArgumentName poolSprocket1) + ] + -- The environment must be passed onto child process on Windows in order to + -- successfully start that process. + <> env + , H.execConfigCwd = Last $ Just tempBaseAbsPath + } + + tipDeadline <- H.noteShowM $ DTC.addUTCTime 180 <$> H.noteShowIO DTC.getCurrentTime + + H.assertByDeadlineMCustom "stdout does not contain \"until genesis start time\"" tipDeadline $ do + H.threadDelay 5000000 + void $ H.execCli' execConfig + [ "query", "tip" + , "--testnet-magic", show @Int testnetMagic + , "--out-file", work "current-tip.json" + ] + + tipJson <- H.leftFailM . H.readJsonFile $ work "current-tip.json" + tip <- H.noteShowM $ H.jsonErrorFail $ J.fromJSON @QueryTipLocalStateOutput tipJson + + currEpoch <- case mEpoch tip of + Nothing -> H.failMessage callStack "cardano-cli query tip returned Nothing for EpochNo" + Just currEpoch -> return currEpoch + + H.note_ $ "Current Epoch: " <> show currEpoch + return (currEpoch > 2) + + stakePoolId <- filter ( /= '\n') <$> H.execCli + [ "stake-pool", "id" + , "--cold-verification-key-file", TR.poolNodeKeysColdVkey $ TR.poolNodeKeys poolNode1 + ] + + let poolVrfSkey = TR.poolNodeKeysVrfSkey $ TR.poolNodeKeys poolNode1 + + id do + scheduleFile <- H.noteTempFile tempAbsPath "schedule.log" + + leadershipScheduleDeadline <- H.noteShowM $ DTC.addUTCTime 180 <$> H.noteShowIO DTC.getCurrentTime + + H.byDeadlineM 5 leadershipScheduleDeadline $ do + void $ H.execCli' execConfig + [ "query", "leadership-schedule" + , "--testnet-magic", show @Int testnetMagic + , "--genesis", TC.shelleyGenesisFile tr + , "--stake-pool-id", stakePoolId + , "--vrf-signing-key-file", poolVrfSkey + , "--out-file", scheduleFile + , "--current" + ] + + scheduleJson <- H.leftFailM $ H.readJsonFile scheduleFile + + expectedLeadershipSlotNumbers <- H.noteShowM $ fmap (fmap slotNumber) $ H.leftFail $ J.parseEither (J.parseJSON @[LeadershipSlot]) scheduleJson + + H.assert $ not (L.null expectedLeadershipSlotNumbers) + + leadershipDeadline <- H.noteShowM $ DTC.addUTCTime 90 <$> H.noteShowIO DTC.getCurrentTime + + H.assertByDeadlineMCustom "Retrieve actual slots" leadershipDeadline $ do + leaderSlots <- H.getRelevantLeaderSlots (TR.poolNodeStdout poolNode1) (minimum expectedLeadershipSlotNumbers) + maxSlotExpected <- H.noteShow $ maximum expectedLeadershipSlotNumbers + if L.null leaderSlots + then return False + else do + maxActualSlot <- H.noteShow $ maximum leaderSlots + return $ maxActualSlot >= maxSlotExpected + + leaderSlots <- H.getRelevantLeaderSlots (TR.poolNodeStdout poolNode1) (minimum expectedLeadershipSlotNumbers) + + H.noteShow_ expectedLeadershipSlotNumbers + H.noteShow_ leaderSlots + + -- As there are no BFT nodes, the next leadership schedule should match slots assigned exactly + H.assert $ L.null (expectedLeadershipSlotNumbers \\ leaderSlots) + + id do + scheduleFile <- H.noteTempFile tempAbsPath "schedule.log" + + leadershipScheduleDeadline <- H.noteShowM $ DTC.addUTCTime 180 <$> H.noteShowIO DTC.getCurrentTime + + H.byDeadlineM 5 leadershipScheduleDeadline $ do + void $ H.execCli' execConfig + [ "query", "leadership-schedule" + , "--testnet-magic", show @Int testnetMagic + , "--genesis", TC.shelleyGenesisFile tr + , "--stake-pool-id", stakePoolId + , "--vrf-signing-key-file", poolVrfSkey + , "--out-file", scheduleFile + , "--next" + ] + + scheduleJson <- H.leftFailM $ H.readJsonFile scheduleFile + + expectedLeadershipSlotNumbers <- H.noteShowM $ fmap (fmap slotNumber) $ H.leftFail $ J.parseEither (J.parseJSON @[LeadershipSlot]) scheduleJson + + H.assert $ not (L.null expectedLeadershipSlotNumbers) + + leadershipDeadline <- H.noteShowM $ DTC.addUTCTime 90 <$> H.noteShowIO DTC.getCurrentTime + + H.assertByDeadlineMCustom "Retrieve actual slots" leadershipDeadline $ do + leaderSlots <- H.getRelevantLeaderSlots (TR.poolNodeStdout poolNode1) (minimum expectedLeadershipSlotNumbers) + maxSlotExpected <- H.noteShow $ maximum expectedLeadershipSlotNumbers + if L.null leaderSlots + then return False + else do + maxActualSlot <- H.noteShow $ maximum leaderSlots + return $ maxActualSlot >= maxSlotExpected + + leaderSlots <- H.getRelevantLeaderSlots (TR.poolNodeStdout poolNode1) (minimum expectedLeadershipSlotNumbers) + + H.noteShow_ expectedLeadershipSlotNumbers + H.noteShow_ leaderSlots + + -- As there are no BFT nodes, the next leadership schedule should match slots assigned exactly + H.assert $ L.null (expectedLeadershipSlotNumbers \\ leaderSlots) diff --git a/cardano-testnet/test/Spec/Cli/KesPeriodInfo.hs b/cardano-testnet/test/Spec/Cli/KesPeriodInfo.hs index 08c8a46bd08..0df3aa7dd87 100644 --- a/cardano-testnet/test/Spec/Cli/KesPeriodInfo.hs +++ b/cardano-testnet/test/Spec/Cli/KesPeriodInfo.hs @@ -25,7 +25,6 @@ import GHC.Stack (callStack) import qualified System.Directory as IO import System.Environment (getEnvironment) import System.FilePath (()) -import System.Info (os) import Cardano.CLI.Shelley.Output import Cardano.CLI.Shelley.Run.Query @@ -40,18 +39,16 @@ import qualified Hedgehog.Extras.Test.Process as H import qualified System.Info as SYS import qualified Test.Base as H import qualified Test.Process as H -import Testnet.Cardano (TestnetOptions (..), TestnetRuntime (..), defaultTestnetOptions, defaultTestnetNodeOptions, - testnet) +import qualified Test.Runtime as TR import qualified Testnet.Cardano as TC -import Testnet.Conf (ProjectBase (..), YamlFilePath (..)) +import Testnet.Cardano (TestnetOptions (..), TestnetRuntime (..), + defaultTestnetNodeOptions, defaultTestnetOptions, testnet) import qualified Testnet.Conf as H +import Testnet.Conf (ProjectBase (..), YamlFilePath (..)) import Testnet.Utils (waitUntilEpoch) import Testnet.Properties.Cli.KesPeriodInfo -isLinux :: Bool -isLinux = os == "linux" - hprop_kes_period_info :: Property hprop_kes_period_info = H.integration . H.runFinallies . H.workspace "chairman" $ \tempAbsBasePath' -> do H.note_ SYS.os @@ -70,7 +67,7 @@ hprop_kes_period_info = H.integration . H.runFinallies . H.workspace "chairman" , activeSlotsCoeff = 0.1 } runTime@TC.TestnetRuntime { testnetMagic } <- testnet fastTestnetOptions conf - let sprockets = TC.bftSprockets runTime + let sprockets = TR.bftSprockets runTime env <- H.evalIO getEnvironment execConfig <- H.noteShow H.ExecConfig @@ -192,7 +189,7 @@ hprop_kes_period_info = H.integration . H.runFinallies . H.workspace "chairman" ] -- Things take long on non-linux machines - if isLinux + if H.isLinux then H.threadDelay 5000000 else H.threadDelay 10000000 @@ -340,7 +337,7 @@ hprop_kes_period_info = H.integration . H.runFinallies . H.workspace "chairman" , "--testnet-magic", show @Int testnetMagic ] - if isLinux + if H.isLinux then H.threadDelay 5000000 else H.threadDelay 20000000 diff --git a/cardano-testnet/test/Test/Util.hs b/cardano-testnet/test/Test/Util.hs index 77103790396..5b874221a75 100644 --- a/cardano-testnet/test/Test/Util.hs +++ b/cardano-testnet/test/Test/Util.hs @@ -4,19 +4,20 @@ module Test.Util , ignoreOnWindows , ignoreOnMac , ignoreOnMacAndWindows + , disabled ) where import Data.Bool (bool) -import Data.String (IsString(..)) +import Data.String (IsString (..)) import Hedgehog (Property) import Hedgehog.Extras.Stock.OS (isWin32) import Prelude import Test.Tasty.ExpectedFailure (wrapTest) import Test.Tasty.Providers (testPassed) -import Test.Tasty.Runners (TestTree, Result(resultShortDescription)) +import Test.Tasty.Runners (Result (resultShortDescription), TestTree) -import qualified Test.Tasty.Hedgehog as H import qualified System.Info as SYS +import qualified Test.Tasty.Hedgehog as H type Os = String @@ -40,3 +41,6 @@ ignoreOn os = wrapTest $ const $ return $ (testPassed ("IGNORED on " <> os)) { resultShortDescription = "IGNORED on " <> os } + +disabled :: String -> Property -> TestTree +disabled pName prop = ignoreOn "Disabled" $ H.testPropertyNamed pName (fromString pName) prop diff --git a/cardano-testnet/testnet/Testnet/Commands.hs b/cardano-testnet/testnet/Testnet/Commands.hs index a87cde414f1..1fdea2c9d71 100644 --- a/cardano-testnet/testnet/Testnet/Commands.hs +++ b/cardano-testnet/testnet/Testnet/Commands.hs @@ -4,6 +4,7 @@ import Data.Function import Data.Monoid import Options.Applicative import System.IO (IO) +import Testnet.Commands.Babbage import Testnet.Commands.Byron import Testnet.Commands.Cardano import Testnet.Commands.Shelley @@ -17,6 +18,7 @@ commands = commandsTestnet <|> commandsGeneral commandsTestnet :: Parser (IO ()) commandsTestnet = hsubparser $ mempty <> commandGroup "Testnets:" + <> cmdBabbage <> cmdByron <> cmdCardano <> cmdShelley diff --git a/cardano-testnet/testnet/Testnet/Commands/Babbage.hs b/cardano-testnet/testnet/Testnet/Commands/Babbage.hs new file mode 100644 index 00000000000..acefe4cd7a1 --- /dev/null +++ b/cardano-testnet/testnet/Testnet/Commands/Babbage.hs @@ -0,0 +1,80 @@ +module Testnet.Commands.Babbage + ( BabbageOptions(..) + , cmdBabbage + , runBabbageOptions + ) where + +import Data.Eq +import Data.Function +import Data.Int +import Data.Maybe +import Data.Semigroup +import Options.Applicative +import System.IO (IO) +import Test.Runtime (readNodeLoggingFormat) +import Testnet.Babbage +import Testnet.Run (runTestnet) +import Text.Show + +import qualified Options.Applicative as OA + +data BabbageOptions = BabbageOptions + { maybeTestnetMagic :: Maybe Int + , testnetOptions :: TestnetOptions + } deriving (Eq, Show) + +optsTestnet :: Parser TestnetOptions +optsTestnet = TestnetOptions + <$> OA.option auto + ( OA.long "num-spo-nodes" + <> OA.help "Number of SPO nodes" + <> OA.metavar "COUNT" + <> OA.showDefault + <> OA.value (numSpoNodes defaultTestnetOptions) + ) + <*> OA.option auto + ( OA.long "slot-duration" + <> OA.help "Slot duration" + <> OA.metavar "MILLISECONDS" + <> OA.showDefault + <> OA.value (slotDuration defaultTestnetOptions) + ) + <*> OA.option auto + ( OA.long "security-param" + <> OA.help "Security parameter" + <> OA.metavar "INT" + <> OA.showDefault + <> OA.value (securityParam defaultTestnetOptions) + ) + <*> OA.option auto + ( OA.long "total-balance" + <> OA.help "Total balance" + <> OA.metavar "INT" + <> OA.showDefault + <> OA.value (totalBalance defaultTestnetOptions) + ) + <*> OA.option (OA.eitherReader readNodeLoggingFormat) + ( OA.long "nodeLoggingFormat" + <> OA.help "Node logging format (json|text)" + <> OA.metavar "LOGGING_FORMAT" + <> OA.showDefault + <> OA.value (nodeLoggingFormat defaultTestnetOptions) + ) + +optsBabbage :: Parser BabbageOptions +optsBabbage = BabbageOptions + <$> optional + ( OA.option auto + ( long "testnet-magic" + <> help "Testnet magic" + <> metavar "INT" + ) + ) + <*> optsTestnet + +runBabbageOptions :: BabbageOptions -> IO () +runBabbageOptions options = runTestnet (maybeTestnetMagic options) $ + Testnet.Babbage.testnet (testnetOptions options) + +cmdBabbage :: Mod CommandFields (IO ()) +cmdBabbage = command "babbage" $ flip info idm $ runBabbageOptions <$> optsBabbage diff --git a/cardano-testnet/testnet/Testnet/Commands/Cardano.hs b/cardano-testnet/testnet/Testnet/Commands/Cardano.hs index f58ecd1e8a0..bedd1bc562a 100644 --- a/cardano-testnet/testnet/Testnet/Commands/Cardano.hs +++ b/cardano-testnet/testnet/Testnet/Commands/Cardano.hs @@ -9,17 +9,18 @@ module Testnet.Commands.Cardano import Data.Eq import Data.Function import Data.Int -import Data.List (replicate) import Data.Maybe import Data.Semigroup import GHC.Enum import Options.Applicative import System.IO (IO) +import Test.Runtime (readNodeLoggingFormat) import Testnet.Cardano import Testnet.Run (runTestnet) import Text.Read import Text.Show +import qualified Data.List as L import qualified Options.Applicative as OA data CardanoOptions = CardanoOptions @@ -30,7 +31,7 @@ data CardanoOptions = CardanoOptions optsTestnet :: Parser TestnetOptions optsTestnet = TestnetOptions <$> OA.option - ((`replicate` defaultTestnetNodeOptions) <$> auto) + ((`L.replicate` defaultTestnetNodeOptions) <$> auto) ( OA.long "num-bft-nodes" <> OA.help "Number of BFT nodes" <> OA.metavar "COUNT" @@ -79,6 +80,13 @@ optsTestnet = TestnetOptions <> OA.showDefault <> OA.value (enableP2P defaultTestnetOptions) ) + <*> OA.option (OA.eitherReader readNodeLoggingFormat) + ( OA.long "nodeLoggingFormat" + <> OA.help "Node logging format (json|text)" + <> OA.metavar "LOGGING_FORMAT" + <> OA.showDefault + <> OA.value (nodeLoggingFormat defaultTestnetOptions) + ) optsCardano :: Parser CardanoOptions optsCardano = CardanoOptions