Skip to content

Commit e294c78

Browse files
carbolymercarbolymer
committed
timestamp impl
1 parent 95d752b commit e294c78

6 files changed

Lines changed: 142 additions & 55 deletions

File tree

‎cardano-api/src/Cardano/Api/Consensus.hs‎

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -52,9 +52,13 @@ module Cardano.Api.Consensus
5252
, CardanoBlock
5353
, ChainDB.ChainDB
5454
, ChainDB.getBlockComponent
55+
, ChainDB.getCurrentLedger
56+
, ConfigSupportsNode
57+
, nodeSystemStart
5558
, ChainDepState
5659
, GenTx (..)
5760
, EraMismatch (..)
61+
, HasHardForkHistory (..)
5862
, HasHeader
5963
, HeaderHash
6064
, NodeKernel (..)
@@ -65,11 +69,16 @@ module Cardano.Api.Consensus
6569
, RealPoint (..)
6670
, ShelleyGenesisStaking (..)
6771
, StandardCrypto
72+
, TopLevelConfig
73+
, ledgerState
6874
, blockNo
6975
, byronIdTx
76+
, configBlock
77+
, configLedger
7078
, condense
7179
, getOpCertCounters
7280
, interpreterToEpochInfo
81+
, mkInterpreter
7382
, unsafeExtendSafeZone
7483
, txId
7584
)

‎cardano-api/src/Cardano/Api/Consensus/Internal/Reexport.hs‎

Lines changed: 18 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -2,39 +2,53 @@ module Cardano.Api.Consensus.Internal.Reexport
22
( BlockComponent (..)
33
, ByronBlock
44
, CardanoBlock
5+
, ConfigSupportsNode
6+
, nodeSystemStart
57
, ChainDepState
68
, GenTx (..)
79
, HasHeader
810
, HeaderHash
911
, EraMismatch (..)
1012
, NodeKernel (..)
1113
, OneEraHash (..)
14+
, HasHardForkHistory (..)
1215
, PastHorizonException
1316
, PraosProtocolSupportsNode
1417
, PraosProtocolSupportsNodeCrypto
1518
, RealPoint (..)
1619
, ShelleyGenesisStaking (..)
1720
, StandardCrypto
21+
, TopLevelConfig
22+
, ledgerState
1823
, blockNo
1924
, byronIdTx
25+
, configBlock
26+
, configLedger
2027
, condense
2128
, getOpCertCounters
2229
, interpreterToEpochInfo
30+
, mkInterpreter
2331
, unsafeExtendSafeZone
2432
, txId
2533
)
2634
where
2735

2836
import Cardano.Protocol.Crypto (StandardCrypto)
37+
import Cardano.Slotting.Time (SystemStart)
2938
import Ouroboros.Consensus.Block (HasHeader, HeaderHash, RealPoint (..), blockNo)
3039
import Ouroboros.Consensus.Byron.Ledger (ByronBlock, GenTx (..), byronIdTx)
3140
import Ouroboros.Consensus.Cardano.Block (CardanoBlock, EraMismatch (..))
41+
import Ouroboros.Consensus.Config (TopLevelConfig, configBlock, configLedger)
42+
import Ouroboros.Consensus.Config.SupportsNode (ConfigSupportsNode (getSystemStart))
43+
import Ouroboros.Consensus.HardFork.Abstract (HasHardForkHistory (..))
3244
import Ouroboros.Consensus.HardFork.Combinator.AcrossEras (OneEraHash (..))
3345
import Ouroboros.Consensus.HardFork.History.EpochInfo (interpreterToEpochInfo)
3446
import Ouroboros.Consensus.HardFork.History.Qry
3547
( PastHorizonException
48+
, mkInterpreter
3649
, unsafeExtendSafeZone
3750
)
51+
import Ouroboros.Consensus.Ledger.Extended (ledgerState)
3852
import Ouroboros.Consensus.Ledger.SupportsMempool (txId)
3953
import Ouroboros.Consensus.Node (NodeKernel (..))
4054
import Ouroboros.Consensus.Protocol.Abstract (ChainDepState)
@@ -46,3 +60,7 @@ import Ouroboros.Consensus.Protocol.Praos.Common
4660
import Ouroboros.Consensus.Shelley.Node (ShelleyGenesisStaking (..))
4761
import Ouroboros.Consensus.Storage.Common (BlockComponent (..))
4862
import Ouroboros.Consensus.Util.Condense (condense)
63+
64+
-- | Extract the network system start time from the node's top-level configuration.
65+
nodeSystemStart :: ConfigSupportsNode blk => TopLevelConfig blk -> SystemStart
66+
nodeSystemStart = getSystemStart . configBlock

‎cardano-rpc/README.md‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -33,7 +33,7 @@ It implements [UTxO RPC](https://utxorpc.org/introduction) protobuf communicatio
3333

3434
| Method | Status |
3535
|--------|--------|
36-
| [FetchBlock](https://utxorpc.org/sync/spec/#fetchblockrequest) | 🚧 In progress (missing: `Block.timestamp`, `Block.body.tx`) |
36+
| [FetchBlock](https://utxorpc.org/sync/spec/#fetchblockrequest) | 🚧 In progress (missing: `Block.body.tx`) |
3737
| [DumpHistory](https://utxorpc.org/sync/spec/#dumphistoryrequest) | ⬜ Not supported |
3838
| [FollowTip](https://utxorpc.org/sync/spec/#followtiprequest) | ⬜ Not supported |
3939
| [ReadTip](https://utxorpc.org/sync/spec/#readtiprequest) | ⬜ Not supported |

‎cardano-rpc/src/Cardano/Rpc/Server/Internal/UtxoRpc/Sync.hs‎

Lines changed: 49 additions & 25 deletions
Original file line numberDiff line numberDiff line change
@@ -19,7 +19,9 @@ import RIO
1919

2020
import Data.ByteString qualified as BS
2121
import Data.ProtoLens (defMessage)
22-
import Network.GRPC.Spec (GrpcError (GrpcInvalidArgument, GrpcNotFound), Proto)
22+
import Data.Time.Clock (UTCTime)
23+
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
24+
import Network.GRPC.Spec (GrpcError (GrpcInternal, GrpcInvalidArgument, GrpcNotFound), Proto)
2325

2426
-- | Handle the @FetchBlock@ SyncService RPC method.
2527
-- Fetches blocks from ChainDB by slot and header hash.
@@ -37,29 +39,51 @@ fetchBlockMethod request = do
3739
blocks <- mapM (fetchOne nodeKernelAccess) blockRefs
3840
pure $ defMessage & U5c.block .~ blocks
3941
where
40-
fetchOne nodeKernelAccess blockRef = do
41-
let slot = SlotNo $ blockRef ^. U5c.slot
42-
hashBytes = blockRef ^. U5c.hash
43-
throwInvalidHash =
44-
throwGrpcErrorWithMessage GrpcInvalidArgument $
45-
"invalid block header hash (" <> tshow (BS.length hashBytes) <> " bytes)"
46-
throwNotFound =
47-
throwGrpcErrorWithMessage GrpcNotFound $
48-
"block not found at slot " <> tshow (unSlotNo slot)
49-
headerHash <-
50-
deserialiseFromRawBytes (proxyToAsType (Proxy @(Hash BlockHeader))) hashBytes
51-
& either (const throwInvalidHash) pure
52-
(rawBytes, BlockNo height) <-
53-
nkaFetchBlock nodeKernelAccess slot headerHash >>= maybe throwNotFound pure
54-
let blockHeader =
55-
defMessage
56-
& U5c.slot .~ unSlotNo slot
57-
& U5c.hash .~ hashBytes
58-
& U5c.height .~ height
59-
-- TODO: timestamp - needs EraHistory from ledger state (snapshot migration)
60-
pure $
61-
defMessage
62-
& U5c.nativeBytes .~ rawBytes
63-
& U5c.cardano . U5c.header .~ blockHeader
42+
fetchOne
43+
:: MonadRpc e m
44+
=> NodeKernelAccessF m
45+
-> Proto U5c.BlockRef
46+
-> m (Proto U5c.AnyChainBlock)
47+
fetchOne
48+
NodeKernelAccessF
49+
{ nkaFetchBlock = fetchBlock
50+
, nkaSystemStart = systemStart
51+
, nkaEraHistory = getEraHistory
52+
}
53+
blockRef = do
54+
let slot = SlotNo $ blockRef ^. U5c.slot
55+
hashBytes = blockRef ^. U5c.hash
56+
throwInvalidHash =
57+
throwGrpcErrorWithMessage GrpcInvalidArgument $
58+
"invalid block header hash (" <> tshow (BS.length hashBytes) <> " bytes)"
59+
throwNotFound =
60+
throwGrpcErrorWithMessage GrpcNotFound $
61+
"block not found at slot " <> tshow (unSlotNo slot)
62+
headerHash <-
63+
deserialiseFromRawBytes (proxyToAsType (Proxy @(Hash BlockHeader))) hashBytes
64+
& either (const throwInvalidHash) pure
65+
(rawBytes, BlockNo height) <-
66+
fetchBlock slot headerHash >>= maybe throwNotFound pure
67+
eraHistory <- getEraHistory
68+
timestampMs <-
69+
slotToUTCTime systemStart eraHistory slot
70+
& either
71+
( const . throwGrpcErrorWithMessage GrpcInternal $
72+
"failed to compute timestamp for slot " <> tshow (unSlotNo slot)
73+
)
74+
(pure . utcTimeToMs)
75+
let blockHeader =
76+
defMessage
77+
& U5c.slot .~ unSlotNo slot
78+
& U5c.hash .~ hashBytes
79+
& U5c.height .~ height
80+
pure $
81+
defMessage
82+
& U5c.nativeBytes .~ rawBytes
83+
& U5c.cardano . U5c.header .~ blockHeader
84+
& U5c.cardano . U5c.timestamp .~ timestampMs
85+
86+
utcTimeToMs :: UTCTime -> Word64
87+
utcTimeToMs = round . (* 1000) . utcTimeToPOSIXSeconds
6488

6589
-- TODO: cardano.body.tx - needs full block deserialisation + UTxO RPC tx mapping

‎cardano-rpc/src/Cardano/Rpc/Server/NodeKernelAccess.hs‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -21,6 +21,10 @@ data NodeKernelAccessF m = NodeKernelAccessF
2121
, nkaFetchBlock :: SlotNo -> Hash BlockHeader -> m (Maybe (ByteString, BlockNo))
2222
-- ^ Fetch raw block CBOR and block number by slot and header hash.
2323
-- Returns 'Nothing' if the block is not found.
24+
, nkaSystemStart :: SystemStart
25+
-- ^ Network system start time.
26+
, nkaEraHistory :: m EraHistory
27+
-- ^ Current era history, computed from the live ledger state.
2428
}
2529

2630
-- | A consistent, read-only view of ledger state at a single chain tip.

‎cardano-rpc/src/Cardano/Rpc/Server/NodeKernelAccess/Internal.hs‎

Lines changed: 61 additions & 29 deletions
Original file line numberDiff line numberDiff line change
@@ -1,8 +1,7 @@
1+
{-# LANGUAGE ApplicativeDo #-}
12
{-# LANGUAGE FlexibleContexts #-}
23
{-# LANGUAGE GADTs #-}
34
{-# LANGUAGE LambdaCase #-}
4-
{-# LANGUAGE RankNTypes #-}
5-
{-# LANGUAGE TypeOperators #-}
65

76
module Cardano.Rpc.Server.NodeKernelAccess.Internal
87
( mkNodeKernelAccess
@@ -15,33 +14,64 @@ import Cardano.Api.Consensus qualified as Consensus
1514
import Cardano.Rpc.Server.Internal.Monad (MonadRpc, grab)
1615
import Cardano.Rpc.Server.NodeKernelAccess
1716

18-
import RIO (throwIO)
17+
import RIO (HasCallStack, atomically, throwIO, tshow)
1918

2019
import Data.ByteString (ByteString)
2120
import Data.ByteString.Lazy qualified as BSL
2221
import Data.IORef
2322
import Network.GRPC.Spec
2423

2524
-- | Construct 'NodeKernelAccessF' from a consensus 'Consensus.NodeKernel'.
26-
-- Only 'nkaFetchBlock' is implemented; snapshot and submit callbacks are stubbed.
25+
-- Only 'nkaFetchBlock' and 'nkaSlotToUTCTime' are implemented; snapshot and submit callbacks
26+
-- throw 'GrpcUnimplemented'. Non-Cardano block types throw 'GrpcInternal'.
2727
mkNodeKernelAccess
28-
:: MonadIO m
28+
:: (HasCallStack, MonadIO m)
2929
=> Consensus.BlockType blk
30-
-- ^ Block type witness, used to bring 'HeaderHash' constraint into scope
30+
-- ^ Block type witness
3131
-> Consensus.NodeKernel IO addrNTN addrNTC blk
3232
-- ^ Consensus node kernel
3333
-> NodeKernelAccessF m
34-
mkNodeKernelAccess blockType nodeKernel =
34+
mkNodeKernelAccess Consensus.CardanoBlockType nodeKernel = do
35+
let chainDb = Consensus.getChainDB nodeKernel
36+
topConfig = Consensus.getTopLevelConfig nodeKernel
3537
NodeKernelAccessF
36-
{ nkaWithSnapshot = \_ -> error "nkaWithSnapshot: not yet implemented (NKA query migration pending)"
37-
, nkaSubmitTx = \_ -> error "nkaSubmitTx: not yet implemented (NKA submit migration pending)"
38-
, nkaFetchBlock = fetchBlock blockType $ Consensus.getChainDB nodeKernel
38+
{ nkaWithSnapshot = \_ -> throwUnimplemented "nkaWithSnapshot"
39+
, nkaSubmitTx = \_ -> throwUnimplemented "nkaSubmitTx"
40+
, nkaFetchBlock = fetchBlock chainDb
41+
, nkaSystemStart = Consensus.nodeSystemStart topConfig
42+
, nkaEraHistory = getEraHistory chainDb topConfig
3943
}
44+
mkNodeKernelAccess blockType _ =
45+
let ex =
46+
GrpcException
47+
{ grpcError = GrpcInternal
48+
, grpcErrorMessage = Just $ "RPC requires CardanoBlockType, got " <> tshow blockType
49+
, grpcErrorDetails = Nothing
50+
, grpcErrorMetadata = []
51+
}
52+
in NodeKernelAccessF
53+
{ nkaWithSnapshot = \_ -> throwIO ex
54+
, nkaSubmitTx = \_ -> throwIO ex
55+
, nkaFetchBlock = \_ _ -> throwIO ex
56+
, nkaSystemStart = error $ "RPC requires CardanoBlockType, got " <> show blockType
57+
, nkaEraHistory = throwIO ex
58+
}
59+
60+
-- | Throw a gRPC UNIMPLEMENTED error for callbacks not yet migrated to NKA.
61+
throwUnimplemented :: (HasCallStack, MonadIO m) => Text -> m a
62+
throwUnimplemented name =
63+
throwIO
64+
GrpcException
65+
{ grpcError = GrpcUnimplemented
66+
, grpcErrorMessage = Just $ name <> ": not yet implemented"
67+
, grpcErrorDetails = Nothing
68+
, grpcErrorMetadata = []
69+
}
4070

4171
-- | Grab the current 'NodeKernelAccessF' from the environment, or throw
4272
-- gRPC UNAVAILABLE if the node kernel has not yet initialised.
4373
grabNodeKernelAccess
44-
:: MonadRpc e m
74+
:: (HasCallStack, MonadRpc e m)
4575
=> m (NodeKernelAccessF m)
4676
grabNodeKernelAccess =
4777
grab >>= liftIO . readIORef >>= \case
@@ -56,31 +86,33 @@ grabNodeKernelAccess =
5686
Just nodeKernelAccess ->
5787
pure nodeKernelAccess
5888

89+
-- | Read the current era history from the live ledger state.
90+
getEraHistory
91+
:: MonadIO m
92+
=> Consensus.ChainDB IO (Consensus.CardanoBlock Consensus.StandardCrypto)
93+
-> Consensus.TopLevelConfig (Consensus.CardanoBlock Consensus.StandardCrypto)
94+
-> m EraHistory
95+
getEraHistory chainDb topConfig = do
96+
extLedgerState <- liftIO . atomically $ Consensus.getCurrentLedger chainDb
97+
let summary =
98+
Consensus.hardForkSummary (Consensus.configLedger topConfig) (Consensus.ledgerState extLedgerState)
99+
pure . EraHistory $ Consensus.mkInterpreter summary
100+
59101
-- | Fetch a raw block and its block number from ChainDB by slot and header hash.
60102
fetchBlock
61103
:: MonadIO m
62-
=> Consensus.BlockType blk
63-
-- ^ Block type witness
64-
-> Consensus.ChainDB IO blk
104+
=> Consensus.ChainDB IO (Consensus.CardanoBlock Consensus.StandardCrypto)
65105
-- ^ Chain database
66106
-> SlotNo
67107
-- ^ Block slot number
68108
-> Hash BlockHeader
69109
-- ^ Block header hash
70110
-> m (Maybe (ByteString, BlockNo))
71111
-- ^ Raw CBOR bytes and block number, or 'Nothing' if not found
72-
fetchBlock blockType chainDB slot (HeaderHash shortHash) =
73-
withBlockTypeConstraints blockType $ do
74-
let point = Consensus.RealPoint slot (Consensus.OneEraHash shortHash)
75-
rawBytes <- liftIO $ Consensus.getBlockComponent chainDB Consensus.GetRawBlock point
76-
typedBlock <- liftIO $ Consensus.getBlockComponent chainDB Consensus.GetBlock point
77-
pure $ liftA2 (,) (BSL.toStrict <$> rawBytes) (Consensus.blockNo <$> typedBlock)
78-
79-
withBlockTypeConstraints
80-
:: Consensus.BlockType blk
81-
-> (forall xs. (Consensus.HeaderHash blk ~ Consensus.OneEraHash xs, Consensus.HasHeader blk) => a)
82-
-> a
83-
withBlockTypeConstraints = \case
84-
Consensus.CardanoBlockType -> id
85-
Consensus.ShelleyBlockType -> id
86-
Consensus.ByronBlockType -> id
112+
fetchBlock chainDb slot (HeaderHash shortHash) = do
113+
let point = Consensus.RealPoint slot (Consensus.OneEraHash shortHash)
114+
getComponent component = liftIO $ Consensus.getBlockComponent chainDb component point
115+
getComponent $ do
116+
rawBytes <- BSL.toStrict <$> Consensus.GetRawBlock
117+
blockNumber <- Consensus.blockNo <$> Consensus.GetBlock
118+
pure (rawBytes, blockNumber)

0 commit comments

Comments
 (0)