Skip to content

Commit 6c08df0

Browse files
carbolymercarbolymer
committed
timestamp impl
1 parent 7859044 commit 6c08df0

5 files changed

Lines changed: 137 additions & 2 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: 77 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -18,7 +18,9 @@ import RIO
1818

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

2325
-- | Handle the @FetchBlock@ SyncService RPC method.
2426
-- Fetches blocks from ChainDB by slot and header hash.
@@ -36,6 +38,7 @@ fetchBlockMethod request = do
3638
blocks <- mapM (fetchOne nodeKernelAccess) blockRefs
3739
pure $ defMessage & U5c.block .~ blocks
3840
where
41+
<<<<<<< HEAD
3942
fetchOne nodeKernelAccess blockRef = do
4043
let slot = SlotNo $ blockRef ^. U5c.slot
4144
hashBytes = blockRef ^. U5c.hash
@@ -60,5 +63,78 @@ fetchBlockMethod request = do
6063
defMessage
6164
& U5c.nativeBytes .~ rawBytes
6265
& U5c.cardano . U5c.header .~ blockHeader
66+
||||||| parent of e294c7818 (timestamp impl)
67+
fetchOne nodeKernelAccess blockRef = do
68+
let slot = SlotNo $ blockRef ^. U5c.slot
69+
hashBytes = blockRef ^. U5c.hash
70+
throwInvalidHash =
71+
throwGrpcErrorWithMessage GrpcInvalidArgument $
72+
"invalid block header hash (" <> tshow (BS.length hashBytes) <> " bytes)"
73+
throwNotFound =
74+
throwGrpcErrorWithMessage GrpcNotFound $
75+
"block not found at slot " <> tshow (unSlotNo slot)
76+
headerHash <-
77+
deserialiseFromRawBytes (proxyToAsType (Proxy @(Hash BlockHeader))) hashBytes
78+
& either (const throwInvalidHash) pure
79+
(rawBytes, BlockNo height) <-
80+
nkaFetchBlock nodeKernelAccess slot headerHash >>= maybe throwNotFound pure
81+
let blockHeader =
82+
defMessage
83+
& U5c.slot .~ unSlotNo slot
84+
& U5c.hash .~ hashBytes
85+
& U5c.height .~ height
86+
-- TODO: timestamp - needs EraHistory from ledger state (snapshot migration)
87+
pure $
88+
defMessage
89+
& U5c.nativeBytes .~ rawBytes
90+
& U5c.cardano . U5c.header .~ blockHeader
91+
=======
92+
fetchOne
93+
:: MonadRpc e m
94+
=> NodeKernelAccessF m
95+
-> Proto U5c.BlockRef
96+
-> m (Proto U5c.AnyChainBlock)
97+
fetchOne
98+
NodeKernelAccessF
99+
{ nkaFetchBlock = fetchBlock
100+
, nkaSystemStart = systemStart
101+
, nkaEraHistory = getEraHistory
102+
}
103+
blockRef = do
104+
let slot = SlotNo $ blockRef ^. U5c.slot
105+
hashBytes = blockRef ^. U5c.hash
106+
throwInvalidHash =
107+
throwGrpcErrorWithMessage GrpcInvalidArgument $
108+
"invalid block header hash (" <> tshow (BS.length hashBytes) <> " bytes)"
109+
throwNotFound =
110+
throwGrpcErrorWithMessage GrpcNotFound $
111+
"block not found at slot " <> tshow (unSlotNo slot)
112+
headerHash <-
113+
deserialiseFromRawBytes (proxyToAsType (Proxy @(Hash BlockHeader))) hashBytes
114+
& either (const throwInvalidHash) pure
115+
(rawBytes, BlockNo height) <-
116+
fetchBlock slot headerHash >>= maybe throwNotFound pure
117+
eraHistory <- getEraHistory
118+
timestampMs <-
119+
slotToUTCTime systemStart eraHistory slot
120+
& either
121+
( const . throwGrpcErrorWithMessage GrpcInternal $
122+
"failed to compute timestamp for slot " <> tshow (unSlotNo slot)
123+
)
124+
(pure . utcTimeToMs)
125+
let blockHeader =
126+
defMessage
127+
& U5c.slot .~ unSlotNo slot
128+
& U5c.hash .~ hashBytes
129+
& U5c.height .~ height
130+
pure $
131+
defMessage
132+
& U5c.nativeBytes .~ rawBytes
133+
& U5c.cardano . U5c.header .~ blockHeader
134+
& U5c.cardano . U5c.timestamp .~ timestampMs
135+
136+
utcTimeToMs :: UTCTime -> Word64
137+
utcTimeToMs = round . (* 1000) . utcTimeToPOSIXSeconds
138+
>>>>>>> e294c7818 (timestamp impl)
63139

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

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

Lines changed: 32 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -25,6 +25,7 @@ import Data.IORef
2525
import Data.Text (pack)
2626
import Network.GRPC.Spec
2727

28+
<<<<<<< HEAD
2829
-- | Construct 'NodeKernelAccess' from a consensus 'Consensus.NodeKernel'.
2930
-- Returns 'Nothing' and traces the block type for non-Cardano block types.
3031
mkNodeKernelAccess
@@ -41,6 +42,37 @@ mkNodeKernelAccess tracer blockType kernel = case blockType of
4142
_ -> do
4243
traceWith tracer $ pack (show blockType)
4344
pure Nothing
45+
||||||| parent of e294c7818 (timestamp impl)
46+
-- | Record of callbacks for in-process access to the node kernel.
47+
-- Constructed by cardano-node once consensus initialisation completes.
48+
data NodeKernelAccessF m = NodeKernelAccessF
49+
{ nkaWithSnapshot :: forall a. (LedgerSnapshot m -> m a) -> m a
50+
-- ^ Acquire a consistent ledger snapshot and run queries against it.
51+
-- All queries within one callback see the same chain tip.
52+
, nkaSubmitTx :: TxInMode -> m (SubmitResult TxValidationErrorInCardanoMode)
53+
-- ^ Submit a transaction to the mempool.
54+
, nkaFetchBlock :: SlotNo -> Hash BlockHeader -> m (Maybe (ByteString, BlockNo))
55+
-- ^ Fetch raw block CBOR and block number by slot and header hash.
56+
-- Returns 'Nothing' if the block is not found.
57+
}
58+
=======
59+
-- | Record of callbacks for in-process access to the node kernel.
60+
-- Constructed by cardano-node once consensus initialisation completes.
61+
data NodeKernelAccessF m = NodeKernelAccessF
62+
{ nkaWithSnapshot :: forall a. (LedgerSnapshot m -> m a) -> m a
63+
-- ^ Acquire a consistent ledger snapshot and run queries against it.
64+
-- All queries within one callback see the same chain tip.
65+
, nkaSubmitTx :: TxInMode -> m (SubmitResult TxValidationErrorInCardanoMode)
66+
-- ^ Submit a transaction to the mempool.
67+
, nkaFetchBlock :: SlotNo -> Hash BlockHeader -> m (Maybe (ByteString, BlockNo))
68+
-- ^ Fetch raw block CBOR and block number by slot and header hash.
69+
-- Returns 'Nothing' if the block is not found.
70+
, nkaSystemStart :: SystemStart
71+
-- ^ Network system start time.
72+
, nkaEraHistory :: m EraHistory
73+
-- ^ Current era history, computed from the live ledger state.
74+
}
75+
>>>>>>> e294c7818 (timestamp impl)
4476

4577
-- | Fetch a raw block and its block number from ChainDB by slot and header hash.
4678
fetchBlock

0 commit comments

Comments
 (0)