Skip to content

Commit

Permalink
#4928 UTC time to slot conversion function
Browse files Browse the repository at this point in the history
  • Loading branch information
carbolymer committed Apr 24, 2023
1 parent 7b0dbdd commit 5b6fd2f
Show file tree
Hide file tree
Showing 3 changed files with 28 additions and 37 deletions.
1 change: 1 addition & 0 deletions cardano-api/src/Cardano/Api.hs
Original file line number Diff line number Diff line change
Expand Up @@ -695,6 +695,7 @@ module Cardano.Api (

EraHistory(..),
getProgress,
getSlotForRelativeTime,

-- *** Common queries
determineEra,
Expand Down
10 changes: 8 additions & 2 deletions cardano-api/src/Cardano/Api/Query.hs
Original file line number Diff line number Diff line change
Expand Up @@ -71,6 +71,7 @@ module Cardano.Api.Query (
LedgerState(..),

getProgress,
getSlotForRelativeTime,

-- * Internal conversion functions
toLedgerUTxO,
Expand All @@ -95,6 +96,8 @@ import Data.SOP.Strict (SListI)
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Typeable
import Data.Word (Word64)
import qualified Data.Aeson.KeyMap as KeyMap

import Ouroboros.Network.Protocol.LocalStateQuery.Client (Some (..))

Expand Down Expand Up @@ -142,9 +145,7 @@ import Cardano.Api.NetworkId
import Cardano.Api.ProtocolParameters
import Cardano.Api.TxBody
import Cardano.Api.Value
import Data.Word (Word64)

import qualified Data.Aeson.KeyMap as KeyMap

-- ----------------------------------------------------------------------------
-- Queries
Expand Down Expand Up @@ -192,6 +193,11 @@ data EraHistory mode where
getProgress :: SlotNo -> EraHistory mode -> Either Qry.PastHorizonException (RelativeTime, SlotLength)
getProgress slotNo (EraHistory _ interpreter) = Qry.interpretQuery interpreter (Qry.slotToWallclock slotNo)

-- | Returns the slot number for provided relative time from 'SystemStart'
getSlotForRelativeTime :: RelativeTime -> EraHistory mode -> Either Qry.PastHorizonException SlotNo
getSlotForRelativeTime relTime (EraHistory _ interpreter) = do
(slotNo, _, _) <- Qry.interpretQuery interpreter $ Qry.wallclockToSlot relTime
pure slotNo

newtype LedgerEpochInfo = LedgerEpochInfo { unLedgerEpochInfo :: Consensus.EpochInfo (Either Text) }

Expand Down
54 changes: 19 additions & 35 deletions cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs
Original file line number Diff line number Diff line change
Expand Up @@ -20,6 +20,7 @@ module Cardano.CLI.Shelley.Run.Query
, renderLocalStateQueryError
, runQueryCmd
, toEpochInfo
, utcTimeToSlotNo
, determineEra
, mergeDelegsAndRewards
, percentage
Expand All @@ -32,7 +33,8 @@ import Cardano.Api.Byron
import Cardano.Api.Orphans ()
import Cardano.Api.Shelley

import Control.Monad.Trans.Except (ExceptT (..), except, runExcept, runExceptT)
import Control.Monad.Trans.Except (ExceptT (..), except, runExcept, runExceptT,
withExceptT)
import Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistEither,
hoistMaybe, left, onLeft, onNothing)
import Data.Aeson as Aeson
Expand Down Expand Up @@ -90,7 +92,7 @@ import qualified Ouroboros.Consensus.HardFork.History.Qry as Qry
import qualified Ouroboros.Consensus.Protocol.Abstract as Consensus
import qualified Ouroboros.Consensus.Protocol.Praos.Common as Consensus

import Control.Monad (forM, forM_, join, foldM)
import Control.Monad (forM, forM_, join)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.IO.Unlift (MonadIO (..))
import Control.Monad.Trans.Class
Expand Down Expand Up @@ -1422,43 +1424,25 @@ toTentativeEpochInfo (EraHistory _ interpreter) =
$ hoistEpochInfo (first (Text.pack . show) . runExcept)
$ Consensus.interpreterToEpochInfo (Consensus.unsafeExtendSafeZone interpreter)


-- | Get slot number for timestamp, or an error if the UTC timestamp is before 'SystemStart'
utcTimeToSlotNo
:: Maybe SocketPath -> AnyConsensusModeParams -> NetworkId -> UTCTime -> ExceptT ShelleyQueryCmdError IO SlotNo
utcTimeToSlotNo mNodeSocketPath (AnyConsensusModeParams cModeParams) network utcTime = do
SocketPath sockPath <- maybe (lift readEnvSocketPath) (pure . Right) mNodeSocketPath
& onLeft (left . ShelleyQueryCmdEnvVarSocketErr)
let cMode = consensusModeOnly cModeParams
allEras = [minBound .. maxBound] :: [AnyCardanoEra]
localNodeConnInfo = LocalNodeConnectInfo cModeParams network sockPath
epochInfos <- case cMode of
:: SocketPath
-> AnyConsensusModeParams
-> NetworkId
-> UTCTime
-> ExceptT ShelleyQueryCmdError IO SlotNo
utcTimeToSlotNo (SocketPath sockPath) (AnyConsensusModeParams cModeParams) network utcTime = do
let localNodeConnInfo = LocalNodeConnectInfo cModeParams network sockPath
case consensusModeOnly cModeParams of
CardanoMode -> do
forM allEras $ \anyE@(AnyCardanoEra era) -> do
sbe <- getSbe (cardanoEraStyle era)
eInMode <- toEraInMode era cMode
& hoistMaybe (ShelleyQueryCmdEraConsensusModeMismatch (AnyConsensusMode cMode) anyE)
let pparamsQuery = QueryInEra eInMode $ QueryInShelleyBasedEra sbe QueryProtocolParameters
ptclStateQuery = QueryInEra eInMode . QueryInShelleyBasedEra sbe $ QueryProtocolState
eraHistoryQuery = QueryEraHistory CardanoModeIsMultiEra

pparams <- executeQuery era cModeParams localNodeConnInfo pparamsQuery
ptclState <- executeQuery era cModeParams localNodeConnInfo ptclStateQuery
eraHistory <- lift (queryNodeLocalState localNodeConnInfo Nothing eraHistoryQuery)
& onLeft (left . ShelleyQueryCmdAcquireFailure)

pure $ toEpochInfo eraHistory

(systemStart, eraHistory) <- withExceptT ShelleyQueryCmdAcquireFailure $
(,) <$> (ExceptT $ queryNodeLocalState localNodeConnInfo Nothing QuerySystemStart)
<*> (ExceptT $ queryNodeLocalState localNodeConnInfo Nothing (QueryEraHistory CardanoModeIsMultiEra))
let relTime = toRelativeTime systemStart utcTime
hoistEither $ Api.getSlotForRelativeTime relTime eraHistory & first ShelleyQueryCmdPastHorizon
mode -> left . ShelleyQueryCmdUnsupportedMode $ AnyConsensusMode mode

let systemStart = undefined :: UTCTime -- FIXME: byron genesis block time

foldl' findSlot (0, SystemStart systemStart)
where
findSlot (slotNo, lastSlotTime) epochInfo
| lastSlotTime > utcTime = slotNo
| otherwise = do
let (firstSlot, lastSlot) = epochInfoRange epochInfo



obtainLedgerEraClassConstraints
:: ShelleyLedgerEra era ~ ledgerera
Expand Down

0 comments on commit 5b6fd2f

Please sign in to comment.