Fix leadership schedule for current on babbage

.stylish-haskell.yaml

@@ -86,7 +86,6 @@ language_extensions:
   - LambdaCase
   - MultiParamTypeClasses
   - MultiWayIf
-  - NoImplicitPrelude
   - OverloadedStrings
   - PolyKinds
   - RecordWildCards

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

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

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

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"

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

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\""