-
Notifications
You must be signed in to change notification settings - Fork 720
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
4106: Fix leadership schedule for current on babbage r=newhoggy a=newhoggy Co-authored-by: John Ky <[email protected]>
- Loading branch information
Showing
18 changed files
with
1,666 additions
and
146 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Large diffs are not rendered by default.
Oops, something went wrong.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -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" |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -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\"" |
Oops, something went wrong.