#4928 Add CLI command for printing slot number for UTC Time

cabal.project

@@ -13,7 +13,7 @@ repository cardano-haskell-packages
 -- See CONTRIBUTING for information about these, including some Nix commands
 -- you need to run if you change them
 index-state:
-  , hackage.haskell.org 2023-05-03T00:00:00Z
+  , hackage.haskell.org 2023-05-08T00:00:00Z
   , cardano-haskell-packages 2023-04-30T00:28:07Z
 
 packages:

cardano-cli/ChangeLog.md

@@ -61,6 +61,8 @@
 
 - Add `utcTimeToSlotNo` function to support UTC -> slot number conversion ([PR 5130](https://github.com/input-output-hk/cardano-node/pull/5130))
 
+- Add `query slot-number` command line option to support UTC -> slot number conversion ([PR 5149](https://github.com/input-output-hk/cardano-node/pull/5149))
+
 - Remove `--stake-address` option from `stake-address build`
   ([PR 5061](https://github.com/input-output-hk/cardano-node/pull/5061))
 

cardano-cli/src/Cardano/CLI/Shelley/Commands.hs

@@ -49,6 +49,7 @@ import           Prelude
 import           Cardano.Api.Shelley
 
 import           Data.Text (Text)
+import           Data.Time.Clock
 
 import           Cardano.CLI.Shelley.Key (DelegationTarget, PaymentVerifier, StakeIdentifier,
                    StakeVerifier, VerificationKeyOrFile, VerificationKeyOrHashOrFile,
@@ -367,6 +368,7 @@ data QueryCmd =
       (Maybe (File () Out))
   | QueryPoolState' SocketPath AnyConsensusModeParams NetworkId [Hash StakePoolKey]
   | QueryTxMempool SocketPath AnyConsensusModeParams NetworkId TxMempoolQuery (Maybe (File () Out))
+  | QuerySlotNumber SocketPath AnyConsensusModeParams NetworkId UTCTime
   deriving Show
 
 renderQueryCmd :: QueryCmd -> Text
@@ -385,6 +387,7 @@ renderQueryCmd cmd =
     QueryKesPeriodInfo {} -> "query kes-period-info"
     QueryPoolState' {} -> "query pool-state"
     QueryTxMempool _ _ _ query _ -> "query tx-mempool" <> renderTxMempoolQuery query
+    QuerySlotNumber {} -> "query slot-number"
   where
     renderTxMempoolQuery query =
       case query of

cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs

@@ -955,6 +955,8 @@ pQueryCmd envCli =
         (Opt.info pQueryPoolState $ Opt.progDesc "Dump the pool state")
     , subParser "tx-mempool"
         (Opt.info pQueryTxMempool $ Opt.progDesc "Local Mempool info")
+    , subParser "slot-number"
+        (Opt.info pQuerySlotNumber $ Opt.progDesc "Query slot number for UTC timestamp")
     ]
   where
     pQueryProtocolParameters :: Parser QueryCmd
@@ -1092,6 +1094,20 @@ pQueryCmd envCli =
         <*> pOperationalCertificateFile
         <*> pMaybeOutputFile
 
+    pQuerySlotNumber :: Parser QueryCmd
+    pQuerySlotNumber =
+      QuerySlotNumber
+        <$> pSocketPath envCli
+        <*> pConsensusModeParams
+        <*> pNetworkId envCli
+        <*> pUtcTimestamp
+          where
+            pUtcTimestamp =
+              convertTime <$> (Opt.strArgument . mconcat)
+                [ Opt.metavar "TIMESTAMP"
+                , Opt.help "UTC timestamp in YYYY-MM-DDThh:mm:ssZ format"
+                ]
+
 pGovernanceCmd :: Parser GovernanceCmd
 pGovernanceCmd =
   asum
@@ -1475,10 +1491,6 @@ pGenesisCmd envCli =
         <> Opt.completer (Opt.bashCompleter "file")
         )
 
-    convertTime :: String -> UTCTime
-    convertTime =
-      parseTimeOrError False defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ"
-
     pInitialSupplyNonDelegated :: Parser (Maybe Lovelace)
     pInitialSupplyNonDelegated =
       Opt.optional $
@@ -1654,6 +1666,10 @@ pTxMetadataJsonSchema =
     -- Default to the no-schema conversion.
     pure TxMetadataJsonNoSchema
 
+convertTime :: String -> UTCTime
+convertTime =
+  parseTimeOrError False defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ"
+
 pMetadataFile :: Parser MetadataFile
 pMetadataFile =
       MetadataFileJSON <$>

cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs

@@ -194,6 +194,8 @@ runQueryCmd cmd =
       runQueryPoolState mNodeSocketPath consensusModeParams network poolid
     QueryTxMempool mNodeSocketPath consensusModeParams network op mOutFile ->
       runQueryTxMempool mNodeSocketPath consensusModeParams network op mOutFile
+    QuerySlotNumber mNodeSocketPath consensusModeParams network utcTime ->
+      runQuerySlotNumber mNodeSocketPath consensusModeParams network utcTime
 
 runQueryProtocolParameters
   :: SocketPath
@@ -352,8 +354,6 @@ runQueryTip socketPath (AnyConsensusModeParams cModeParams) network mOutFile = d
 
 -- | Query the UTxO, filtered by a given set of addresses, from a Shelley node
 -- via the local state query protocol.
---
-
 runQueryUTxO
   :: SocketPath
   -> AnyConsensusModeParams
@@ -698,6 +698,15 @@ runQueryTxMempool socketPath (AnyConsensusModeParams cModeParams) network query
     Just (File oFp) -> handleIOExceptT (ShelleyQueryCmdWriteFileError . FileIOError oFp)
         $ LBS.writeFile oFp renderedResult
 
+runQuerySlotNumber
+  :: SocketPath
+  -> AnyConsensusModeParams
+  -> NetworkId
+  -> UTCTime
+  -> ExceptT ShelleyQueryCmdError IO ()
+runQuerySlotNumber sockPath aCmp network utcTime = do
+  SlotNo slotNo <- utcTimeToSlotNo sockPath aCmp network utcTime
+  liftIO $ print slotNo
 
 -- | Obtain stake snapshot information for a pool, plus information about the total active stake.
 -- This information can be used for leader slot calculation, for example, and has been requested by SPOs.

cardano-testnet/cardano-testnet.cabal

@@ -38,14 +38,17 @@ library
                       , cardano-cli
                       , cardano-crypto-class
                       , cardano-git-rev
+                      , cardano-ledger-core
                       , cardano-ledger-byron
+                      , cardano-ledger-shelley
                       , cardano-node
                       , containers
                       , directory
                       , exceptions
                       , filepath
                       , hedgehog
-                      , hedgehog-extras ^>= 0.4.3
+                      , hedgehog-extras ^>= 0.4.4
+                      , mtl
                       , optparse-applicative-fork
                       , ouroboros-network
                       , ouroboros-network-api
@@ -66,6 +69,7 @@ library
 
   hs-source-dirs:       src
   exposed-modules:      Cardano.Testnet
+                        Testnet.Babbage
                         Testnet.Byron
                         Testnet.Util.Assert
                         Testnet.Util.Base
@@ -81,7 +85,6 @@ library
                         Parsers.Shelley
                         Parsers.Version
                         Testnet
-                        Testnet.Babbage
                         Testnet.Cardano
                         Testnet.Conf
                         Testnet.Commands.Genesis
@@ -117,6 +120,7 @@ test-suite cardano-testnet-tests
                         Test.Cli.Babbage.LeadershipSchedule
                         Test.Cli.Babbage.StakeSnapshot
                         Test.Cli.KesPeriodInfo
+                        Test.Cli.QuerySlotNumber
                         Test.FoldBlocks
                         Test.Misc
                         Test.Node.Shutdown
@@ -134,7 +138,7 @@ test-suite cardano-testnet-tests
                       , directory
                       , filepath
                       , hedgehog
-                      , hedgehog-extras ^>= 0.4.3
+                      , hedgehog-extras ^>= 0.4.4
                       , process
                       , tasty
                       , text

cardano-testnet/src/Testnet/Util/Runtime.hs

@@ -2,6 +2,8 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module Testnet.Util.Runtime
   ( LeadershipSlot(..)
@@ -19,29 +21,42 @@ module Testnet.Util.Runtime
   , poolNodeStdout
   , readNodeLoggingFormat
   , startNode
+  , ShelleyGenesis(..)
+  , shelleyGenesis
+  , getStartTime
+  , fromNominalDiffTimeMicro
   ) where
 
 import           Prelude
 
 import           Control.Monad
-import           Data.Aeson (FromJSON)
+import           Control.Monad.Error.Class
+import           Control.Monad.IO.Class
+import           Control.Monad.Trans.Except
+import           Data.Aeson ((.:))
+import qualified Data.Aeson as A
+import qualified Data.Aeson.Types as A
 import qualified Data.List as L
-
 import           Data.Text (Text)
+import           Data.Time.Clock (UTCTime)
+import           Data.Time.Clock.POSIX (posixSecondsToUTCTime)
 import           GHC.Generics (Generic)
+import           GHC.Stack
 import qualified Hedgehog as H
 import           Hedgehog.Extras.Stock.IO.Network.Sprocket (Sprocket (..))
 import qualified Hedgehog.Extras.Stock.IO.Network.Sprocket as IO
 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           System.FilePath.Posix ((</>))
 import qualified System.Info as OS
 import qualified System.IO as IO
 import qualified System.Process as IO
 
+import           Cardano.Api
+import           Cardano.Ledger.Crypto (StandardCrypto)
+import           Cardano.Ledger.Shelley.Genesis
 import qualified Testnet.Util.Process as H
 
 data NodeLoggingFormat = NodeLoggingFormatAsJson | NodeLoggingFormatAsText deriving (Eq, Show)
@@ -108,6 +123,22 @@ bftSprockets = fmap nodeSprocket . bftNodes
 poolSprockets :: TestnetRuntime -> [Sprocket]
 poolSprockets = fmap (nodeSprocket . poolRuntime) . poolNodes
 
+shelleyGenesis :: (H.MonadTest m, MonadIO m, HasCallStack) => TestnetRuntime -> m (ShelleyGenesis StandardCrypto)
+shelleyGenesis TestnetRuntime{shelleyGenesisFile} = withFrozenCallStack $
+  H.evalEither =<< H.evalIO (A.eitherDecodeFileStrict' shelleyGenesisFile)
+
+getStartTime :: (H.MonadTest m, MonadIO m, HasCallStack) => FilePath -> TestnetRuntime -> m UTCTime
+getStartTime tempRootPath TestnetRuntime{configurationFile} = withFrozenCallStack $ H.evalEither <=< H.evalIO . runExceptT $ do
+  testnetConfig <- ExceptT $ A.eitherDecodeFileStrict' configurationFile
+  byronGenesisFile <- liftEither $ A.parseEither
+      (A.withObject ("testnet configuration file: " <> configurationFile) (.: "ByronGenesisFile"))
+      testnetConfig
+  let byronGenesisFilePath = tempRootPath </> byronGenesisFile
+  genesisConfig <- ExceptT $ A.eitherDecodeFileStrict' byronGenesisFilePath
+  fmap posixSecondsToUTCTime . liftEither $ A.parseEither
+      (A.withObject ("byron genesis file: " <> byronGenesisFilePath) (.: "startTime"))
+      genesisConfig
+
 readNodeLoggingFormat :: String -> Either String NodeLoggingFormat
 readNodeLoggingFormat = \case
   "json" -> Right NodeLoggingFormatAsJson

cardano-testnet/test/Main.hs

@@ -16,6 +16,7 @@ import qualified Test.Tasty.Ingredients as T
 import qualified Test.Cli.Babbage.LeadershipSchedule
 import qualified Test.Cli.Babbage.StakeSnapshot
 import qualified Test.Cli.KesPeriodInfo
+import qualified Test.Cli.QuerySlotNumber
 import qualified Test.FoldBlocks
 import qualified Test.Node.Shutdown
 import qualified Test.ShutdownOnSlotSynced
@@ -39,6 +40,7 @@ tests = pure $ T.testGroup "test/Spec.hs"
       -- 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" Test.Cli.KesPeriodInfo.hprop_kes_period_info
+    , H.ignoreOnWindows "query-slot-number" Test.Cli.QuerySlotNumber.hprop_querySlotNumber
     ]
   , H.ignoreOnWindows "foldBlocks receives ledger state" Test.FoldBlocks.prop_foldBlocks
   ]