Skip to content

Commit 45590a6

Browse files
jasagredojasagredo
committed
Implement LSM instances for all blocks
1 parent 28b4117 commit 45590a6

File tree

15 files changed

+189
-11
lines changed

15 files changed

+189
-11
lines changed

‎ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -167,6 +167,7 @@ library
167167
ouroboros-consensus ^>=0.27,
168168
ouroboros-consensus-protocol ^>=0.12,
169169
ouroboros-network-api ^>=0.16,
170+
primitive,
170171
serialise ^>=0.2,
171172
singletons ^>=3.0,
172173
small-steps,
@@ -176,6 +177,7 @@ library
176177
text,
177178
these ^>=1.2,
178179
validation,
180+
vector,
179181
vector-map,
180182

181183
library unstable-byronspec

‎ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/ByronHFC.hs‎

Lines changed: 12 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -11,6 +11,7 @@
1111
{-# LANGUAGE StandaloneDeriving #-}
1212
{-# LANGUAGE TypeApplications #-}
1313
{-# LANGUAGE TypeFamilies #-}
14+
{-# LANGUAGE UndecidableInstances #-}
1415
{-# OPTIONS_GHC -Wno-orphans #-}
1516

1617
module Ouroboros.Consensus.Byron.ByronHFC
@@ -45,6 +46,8 @@ import Ouroboros.Consensus.Ledger.Query
4546
import Ouroboros.Consensus.Node.NetworkProtocolVersion
4647
import Ouroboros.Consensus.Node.Serialisation
4748
import Ouroboros.Consensus.Protocol.PBFT (PBft, PBftCrypto)
49+
import Ouroboros.Consensus.Storage.LedgerDB
50+
import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.LSM as LSM
4851
import Ouroboros.Consensus.Storage.Serialisation
4952
import Ouroboros.Consensus.Util.IndexedMemPack
5053

@@ -292,7 +295,7 @@ instance HasCanonicalTxIn '[ByronBlock] where
292295
{ getByronHFCTxIn :: Void
293296
}
294297
deriving stock (Show, Eq, Ord)
295-
deriving newtype (NoThunks, MemPack)
298+
deriving newtype (NoThunks, MemPack, LSM.SerialiseKey)
296299

297300
injectCanonicalTxIn IZ key = absurd key
298301
injectCanonicalTxIn (IS idx') _ = case idx' of {}
@@ -311,6 +314,14 @@ deriving via
311314
instance
312315
IndexedMemPack (LedgerState (HardForkBlock '[ByronBlock]) EmptyMK) Void
313316

317+
type instance
318+
LSMTxOut (LedgerState (HardForkBlock '[ByronBlock])) =
319+
TxOut (LedgerState (HardForkBlock '[ByronBlock]))
320+
321+
instance HasLSMTxOut (LedgerState (HardForkBlock '[ByronBlock])) where
322+
toLSMTxOut _ = id
323+
fromLSMTxOut _ = id
324+
314325
instance BlockSupportsHFLedgerQuery '[ByronBlock] where
315326
answerBlockQueryHFLookup IZ _cfg (q :: BlockQuery ByronBlock QFLookupTables result) _dlv = case q of {}
316327
answerBlockQueryHFLookup (IS is) _cfg _q _dlv = case is of {}

‎ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -14,6 +14,7 @@
1414
{-# LANGUAGE ScopedTypeVariables #-}
1515
{-# LANGUAGE StandaloneDeriving #-}
1616
{-# LANGUAGE TypeFamilies #-}
17+
{-# LANGUAGE UndecidableInstances #-}
1718
{-# OPTIONS_GHC -Wno-orphans #-}
1819

1920
-- | Instances requires for consensus/ledger integration
@@ -202,6 +203,11 @@ instance IsLedger (LedgerState ByronBlock) where
202203

203204
type instance TxIn (LedgerState ByronBlock) = Void
204205
type instance TxOut (LedgerState ByronBlock) = Void
206+
type instance LSMTxOut (LedgerState ByronBlock) = TxOut (LedgerState ByronBlock)
207+
208+
instance HasLSMTxOut (LedgerState ByronBlock) where
209+
toLSMTxOut _ = id
210+
fromLSMTxOut _ = id
205211

206212
instance LedgerTablesAreTrivial (LedgerState ByronBlock) where
207213
convertMapKind (ByronLedgerState x y z) = ByronLedgerState x y z

‎ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Ledger.hs‎

Lines changed: 21 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -3,7 +3,7 @@
33
{-# LANGUAGE DataKinds #-}
44
{-# LANGUAGE DeriveAnyClass #-}
55
{-# LANGUAGE DeriveGeneric #-}
6-
{-# LANGUAGE DerivingStrategies #-}
6+
{-# LANGUAGE DerivingVia #-}
77
{-# LANGUAGE EmptyCase #-}
88
{-# LANGUAGE FlexibleContexts #-}
99
{-# LANGUAGE FlexibleInstances #-}
@@ -13,6 +13,7 @@
1313
{-# LANGUAGE MultiParamTypeClasses #-}
1414
{-# LANGUAGE RankNTypes #-}
1515
{-# LANGUAGE ScopedTypeVariables #-}
16+
{-# LANGUAGE StandaloneDeriving #-}
1617
{-# LANGUAGE TypeApplications #-}
1718
{-# LANGUAGE TypeFamilies #-}
1819
{-# LANGUAGE UndecidableInstances #-}
@@ -38,13 +39,15 @@ import Codec.CBOR.Decoding
3839
import Codec.CBOR.Encoding
3940
import qualified Data.Map as Map
4041
import Data.MemPack
42+
import qualified Data.Primitive.ByteArray as PBA
4143
import Data.Proxy
4244
import Data.SOP.BasicFunctors
4345
import Data.SOP.Functors
4446
import Data.SOP.Index
4547
import Data.SOP.Strict
4648
import qualified Data.SOP.Tails as Tails
4749
import qualified Data.SOP.Telescope as Telescope
50+
import Data.Vector.Primitive (Vector (..))
4851
import Data.Void
4952
import GHC.Generics (Generic)
5053
import Lens.Micro
@@ -62,6 +65,7 @@ import Ouroboros.Consensus.Shelley.Ledger
6265
, ShelleyCompatible
6366
, shelleyLedgerState
6467
)
68+
import Ouroboros.Consensus.Storage.LedgerDB.V2.LSM
6569
import Ouroboros.Consensus.TypeFamilyWrappers
6670
import Ouroboros.Consensus.Util.IndexedMemPack
6771

@@ -73,7 +77,7 @@ instance
7377
{ getCardanoTxIn :: SL.TxIn
7478
}
7579
deriving stock (Show, Eq, Ord)
76-
deriving newtype NoThunks
80+
deriving newtype (NoThunks, SerialiseKey)
7781

7882
injectCanonicalTxIn IZ byronTxIn = absurd byronTxIn
7983
injectCanonicalTxIn (IS idx) shelleyTxIn = case idx of
@@ -114,6 +118,21 @@ data CardanoTxOut c
114118
deriving stock (Show, Eq, Generic)
115119
deriving anyclass NoThunks
116120

121+
type instance LSMTxOut (LedgerState (CardanoBlock c)) = RawBytes
122+
123+
instance SerialiseValue RawBytes where
124+
serialiseValue = id
125+
deserialiseValue = id
126+
127+
deriving via ResolveAsFirst RawBytes instance ResolveValue RawBytes
128+
129+
instance CardanoHardForkConstraints c => HasLSMTxOut (LedgerState (CardanoBlock c)) where
130+
toLSMTxOut _ txout =
131+
let barr = eliminateCardanoTxOut (const pack) txout
132+
in RawBytes (Vector 0 (PBA.sizeofByteArray barr) barr)
133+
fromLSMTxOut st (RawBytes (Vector _ _ barr)) =
134+
indexedUnpackError st barr
135+
117136
-- | Eliminate the wrapping of CardanoTxOut with the provided function. Similar
118137
-- to 'hcimap' on an 'NS'.
119138
eliminateCardanoTxOut ::

‎ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Eras.hs‎

Lines changed: 19 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,11 +1,13 @@
11
{-# LANGUAGE AllowAmbiguousTypes #-}
22
{-# LANGUAGE DataKinds #-}
3+
{-# LANGUAGE DerivingVia #-}
34
{-# LANGUAGE FlexibleContexts #-}
45
{-# LANGUAGE FlexibleInstances #-}
56
{-# LANGUAGE GADTs #-}
67
{-# LANGUAGE LambdaCase #-}
78
{-# LANGUAGE MultiParamTypeClasses #-}
89
{-# LANGUAGE ScopedTypeVariables #-}
10+
{-# LANGUAGE StandaloneDeriving #-}
911
{-# LANGUAGE TypeApplications #-}
1012
{-# LANGUAGE TypeFamilies #-}
1113
{-# LANGUAGE UndecidableInstances #-}
@@ -70,6 +72,7 @@ import Ouroboros.Consensus.Ledger.SupportsMempool
7072
( WhetherToIntervene (..)
7173
)
7274
import Ouroboros.Consensus.Protocol.TPraos (StandardCrypto)
75+
import Ouroboros.Consensus.Storage.LedgerDB.V2.LSM
7376

7477
{-------------------------------------------------------------------------------
7578
Era polymorphism
@@ -328,3 +331,19 @@ instance SupportsTwoPhaseValidation DijkstraEra where
328331
)
329332
) -> True
330333
_ -> False
334+
335+
{-------------------------------------------------------------------------------
336+
SerialiseValue
337+
338+
These instances are necessary only to support threadnet shelley tests and the
339+
unstable-cardano-tools library.
340+
-------------------------------------------------------------------------------}
341+
342+
instance SerialiseValue (SL.ShelleyTxOut ShelleyEra) where
343+
serialiseValue = serialiseLSMViaMemPack
344+
deserialiseValue = deserialiseLSMViaMemPack
345+
346+
deriving via
347+
ResolveAsFirst (SL.ShelleyTxOut ShelleyEra)
348+
instance
349+
ResolveValue (SL.ShelleyTxOut ShelleyEra)

‎ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs‎

Lines changed: 28 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -2,7 +2,7 @@
22
{-# LANGUAGE DataKinds #-}
33
{-# LANGUAGE DeriveAnyClass #-}
44
{-# LANGUAGE DeriveGeneric #-}
5-
{-# LANGUAGE DerivingStrategies #-}
5+
{-# LANGUAGE DerivingVia #-}
66
{-# LANGUAGE DisambiguateRecordFields #-}
77
{-# LANGUAGE FlexibleContexts #-}
88
{-# LANGUAGE FlexibleInstances #-}
@@ -130,6 +130,7 @@ import Ouroboros.Consensus.Shelley.Protocol.Abstract
130130
, mkHeaderView
131131
)
132132
import Ouroboros.Consensus.Storage.LedgerDB
133+
import Ouroboros.Consensus.Storage.LedgerDB.V2.LSM
133134
import Ouroboros.Consensus.Util.CBOR
134135
( decodeWithOrigin
135136
, encodeWithOrigin
@@ -320,6 +321,32 @@ instance ShelleyCompatible proto era => UpdateLedger (ShelleyBlock proto era)
320321
type instance TxIn (LedgerState (ShelleyBlock proto era)) = SL.TxIn
321322
type instance TxOut (LedgerState (ShelleyBlock proto era)) = Core.TxOut era
322323

324+
-- | We use this newtype only to alter MemPack serialization. LSM trees use an
325+
-- index that looks at the first 8 bytes so it is important to put the index
326+
-- first such that we avoid all TxIns from the same tx to imply a collision in
327+
-- the LSM index.
328+
newtype LSMTxIn = LSMTxIn {lsmTxIn :: SL.TxIn}
329+
330+
instance MemPack LSMTxIn where
331+
packedByteCount = packedByteCount . lsmTxIn
332+
packM (LSMTxIn (SL.TxIn txid txix)) = packM txix >> packM txid
333+
unpackM = do
334+
txix <- unpackM
335+
txid <- unpackM
336+
pure . LSMTxIn $ SL.TxIn txid txix
337+
338+
instance SerialiseKey SL.TxIn where
339+
serialiseKey = serialiseLSMViaMemPack . LSMTxIn
340+
deserialiseKey = lsmTxIn . deserialiseLSMViaMemPack
341+
342+
type instance
343+
LSMTxOut (LedgerState (ShelleyBlock proto era)) =
344+
TxOut (LedgerState (ShelleyBlock proto era))
345+
346+
instance HasLSMTxOut (LedgerState (ShelleyBlock proto era)) where
347+
toLSMTxOut _ = id
348+
fromLSMTxOut _ = id
349+
323350
instance
324351
(txout ~ Core.TxOut era, MemPack txout) =>
325352
IndexedMemPack (LedgerState (ShelleyBlock proto era) EmptyMK) txout

‎ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs‎

Lines changed: 11 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -10,7 +10,6 @@
1010
{-# LANGUAGE OverloadedStrings #-}
1111
{-# LANGUAGE RecordWildCards #-}
1212
{-# LANGUAGE ScopedTypeVariables #-}
13-
{-# LANGUAGE StandaloneDeriving #-}
1413
{-# LANGUAGE TypeApplications #-}
1514
{-# LANGUAGE TypeFamilies #-}
1615
{-# LANGUAGE TypeOperators #-}
@@ -92,6 +91,8 @@ import Ouroboros.Consensus.Shelley.Ledger
9291
import Ouroboros.Consensus.Shelley.Ledger.Inspect as Shelley.Inspect
9392
import Ouroboros.Consensus.Shelley.Node ()
9493
import Ouroboros.Consensus.Shelley.Protocol.Abstract (ProtoCrypto)
94+
import Ouroboros.Consensus.Storage.LedgerDB.API
95+
import Ouroboros.Consensus.Storage.LedgerDB.V2.LSM
9596
import Ouroboros.Consensus.TypeFamilyWrappers
9697
import Ouroboros.Consensus.Util.IndexedMemPack
9798

@@ -168,6 +169,7 @@ instance
168169
, LedgerSupportsProtocol (ShelleyBlock proto era)
169170
, TxLimits (ShelleyBlock proto era)
170171
, Crypto (ProtoCrypto proto)
172+
, LedgerSupportsLSMLedgerDB (LedgerState (ShelleyBlock proto era))
171173
) =>
172174
SerialiseHFC '[ShelleyBlock proto era]
173175

@@ -429,15 +431,21 @@ instance
429431
{ getShelleyBlockHFCTxIn :: SL.TxIn
430432
}
431433
deriving stock (Show, Eq, Ord)
432-
deriving newtype NoThunks
434+
deriving newtype (NoThunks, MemPack, SerialiseKey)
433435

434436
injectCanonicalTxIn IZ txIn = ShelleyBlockHFCTxIn txIn
435437
injectCanonicalTxIn (IS idx') _ = case idx' of {}
436438

437439
ejectCanonicalTxIn IZ txIn = getShelleyBlockHFCTxIn txIn
438440
ejectCanonicalTxIn (IS idx') _ = case idx' of {}
439441

440-
deriving newtype instance MemPack (CanonicalTxIn '[ShelleyBlock proto era])
442+
type instance
443+
LSMTxOut (LedgerState (HardForkBlock '[ShelleyBlock proto era])) =
444+
TxOut (LedgerState (HardForkBlock '[ShelleyBlock proto era]))
445+
446+
instance HasLSMTxOut (LedgerState (HardForkBlock '[ShelleyBlock proto era])) where
447+
toLSMTxOut _ = id
448+
fromLSMTxOut _ = id
441449

442450
{-------------------------------------------------------------------------------
443451
HardForkTxOut

‎ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs‎

Lines changed: 16 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -94,6 +94,7 @@ import Ouroboros.Consensus.Shelley.Ledger
9494
import Ouroboros.Consensus.Shelley.Node
9595
import Ouroboros.Consensus.Shelley.Protocol.Abstract (ProtoCrypto)
9696
import Ouroboros.Consensus.Storage.LedgerDB
97+
import Ouroboros.Consensus.Storage.LedgerDB.V2.LSM
9798
import Ouroboros.Consensus.TypeFamilyWrappers
9899
import Ouroboros.Consensus.Util (eitherToMaybe)
99100
import Ouroboros.Consensus.Util.IOLike (IOLike)
@@ -512,6 +513,21 @@ deriving newtype instance
512513
ShelleyBasedHardForkConstraints proto1 era1 proto2 era2 =>
513514
MemPack (CanonicalTxIn (ShelleyBasedHardForkEras proto1 era1 proto2 era2))
514515

516+
type instance
517+
LSMTxOut (LedgerState (HardForkBlock (ShelleyBasedHardForkEras proto1 era1 proto2 era2))) =
518+
TxOut (LedgerState (HardForkBlock (ShelleyBasedHardForkEras proto1 era1 proto2 era2)))
519+
520+
instance HasLSMTxOut (LedgerState (HardForkBlock (ShelleyBasedHardForkEras proto1 era1 proto2 era2))) where
521+
toLSMTxOut _ = id
522+
fromLSMTxOut _ = id
523+
524+
instance
525+
ShelleyBasedHardForkConstraints proto1 era1 proto2 era2 =>
526+
SerialiseKey (CanonicalTxIn (ShelleyBasedHardForkEras proto1 era1 proto2 era2))
527+
where
528+
serialiseKey = serialiseLSMViaMemPack
529+
deserialiseKey = deserialiseLSMViaMemPack
530+
515531
instance
516532
ShelleyBasedHardForkConstraints proto1 era1 proto2 era2 =>
517533
HasHardForkTxOut (ShelleyBasedHardForkEras proto1 era1 proto2 era2)

‎ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs‎

Lines changed: 11 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -14,6 +14,7 @@
1414
{-# LANGUAGE ScopedTypeVariables #-}
1515
{-# LANGUAGE TypeApplications #-}
1616
{-# LANGUAGE TypeFamilies #-}
17+
{-# LANGUAGE UndecidableInstances #-}
1718
{-# OPTIONS_GHC -Wno-orphans #-}
1819

1920
module Test.Consensus.HardFork.Combinator (tests) where
@@ -56,6 +57,7 @@ import Ouroboros.Consensus.Protocol.LeaderSchedule
5657
( LeaderSchedule (..)
5758
, leaderScheduleFor
5859
)
60+
import Ouroboros.Consensus.Storage.LedgerDB.V2.LSM
5961
import Ouroboros.Consensus.TypeFamilyWrappers
6062
import Ouroboros.Consensus.Util.IndexedMemPack
6163
import Ouroboros.Consensus.Util.Orphans ()
@@ -412,7 +414,7 @@ instance HasCanonicalTxIn '[BlockA, BlockB] where
412414
{ getBlockABTxIn :: Void
413415
}
414416
deriving stock (Show, Eq, Ord)
415-
deriving newtype (NoThunks, MemPack)
417+
deriving newtype (NoThunks, MemPack, SerialiseKey)
416418

417419
injectCanonicalTxIn IZ key = absurd key
418420
injectCanonicalTxIn (IS IZ) key = absurd key
@@ -472,6 +474,14 @@ instance SupportedNetworkProtocolVersion TestBlock where
472474

473475
latestReleasedNodeVersion = latestReleasedNodeVersionDefault
474476

477+
type instance
478+
LSMTxOut (LedgerState (HardForkBlock [BlockA, BlockB])) =
479+
TxOut (LedgerState (HardForkBlock [BlockA, BlockB]))
480+
481+
instance HasLSMTxOut (LedgerState (HardForkBlock [BlockA, BlockB])) where
482+
toLSMTxOut _ = id
483+
fromLSMTxOut _ = id
484+
475485
instance SerialiseHFC '[BlockA, BlockB]
476486

477487
-- Use defaults

0 commit comments

Comments
 (0)