Skip to content

Commit 2f269eb

Browse files
jasagredojasagredo
committed
propagate to all packages
1 parent 476f84e commit 2f269eb

File tree

13 files changed

+215
-83
lines changed

13 files changed

+215
-83
lines changed

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

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -163,7 +163,9 @@ library
163163
microlens,
164164
mtl,
165165
nothunks,
166+
lsm-tree,
166167
ouroboros-consensus ^>=0.27,
168+
vector,
167169
ouroboros-consensus-protocol ^>=0.12,
168170
ouroboros-network-api ^>=0.14,
169171
serialise ^>=0.2,
@@ -172,6 +174,8 @@ library
172174
sop-core ^>=0.5,
173175
sop-extras ^>=0.4,
174176
strict-sop-core ^>=0.1,
177+
primitive,
178+
FailT,
175179
text,
176180
these ^>=1.2,
177181
validation,

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

Lines changed: 7 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -29,6 +29,7 @@ import Data.MemPack
2929
import Data.SOP.Index (Index (..))
3030
import Data.Void (Void, absurd)
3131
import Data.Word
32+
import qualified Database.LSMTree as LSM
3233
import GHC.Generics
3334
import NoThunks.Class
3435
import Ouroboros.Consensus.Block
@@ -45,6 +46,7 @@ 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.V2.LSM
4850
import Ouroboros.Consensus.Storage.Serialisation
4951
import Ouroboros.Consensus.Util.IndexedMemPack
5052

@@ -292,7 +294,7 @@ instance HasCanonicalTxIn '[ByronBlock] where
292294
{ getByronHFCTxIn :: Void
293295
}
294296
deriving stock (Show, Eq, Ord)
295-
deriving newtype (NoThunks, MemPack)
297+
deriving newtype (NoThunks, MemPack, LSM.SerialiseKey, LSM.SerialiseValue, LSM.ResolveValue)
296298

297299
injectCanonicalTxIn IZ key = absurd key
298300
injectCanonicalTxIn (IS idx') _ = case idx' of {}
@@ -311,6 +313,10 @@ deriving via
311313
instance
312314
IndexedMemPack (LedgerState (HardForkBlock '[ByronBlock]) EmptyMK) Void
313315

316+
instance LSMOrder (LedgerState (HardForkBlock '[ByronBlock])) where
317+
toLSMOrder _ [] = []
318+
toLSMOrder _ (x : _) = absurd . getByronHFCTxIn $ x
319+
314320
instance BlockSupportsHFLedgerQuery '[ByronBlock] where
315321
answerBlockQueryHFLookup IZ _cfg (q :: BlockQuery ByronBlock QFLookupTables result) _dlv = case q of {}
316322
answerBlockQueryHFLookup (IS is) _cfg _q _dlv = case is of {}

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

Lines changed: 13 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -70,7 +70,8 @@ import qualified Control.State.Transition.Extended as STS
7070
import Data.ByteString (ByteString)
7171
import Data.Map.Strict (Map)
7272
import qualified Data.Map.Strict as Map
73-
import Data.Void (Void)
73+
import Data.Void (Void, absurd)
74+
import qualified Database.LSMTree as LSM
7475
import GHC.Generics (Generic)
7576
import NoThunks.Class (NoThunks)
7677
import Ouroboros.Consensus.Block
@@ -92,6 +93,7 @@ import Ouroboros.Consensus.Ledger.SupportsPeerSelection
9293
import Ouroboros.Consensus.Ledger.SupportsProtocol
9394
import Ouroboros.Consensus.Ledger.Tables.Utils
9495
import Ouroboros.Consensus.Storage.LedgerDB
96+
import Ouroboros.Consensus.Storage.LedgerDB.V2.LSM
9597
import Ouroboros.Consensus.Util (ShowProxy (..))
9698
import Ouroboros.Consensus.Util.IndexedMemPack
9799

@@ -203,6 +205,16 @@ instance IsLedger (LedgerState ByronBlock) where
203205
type instance TxIn (LedgerState ByronBlock) = Void
204206
type instance TxOut (LedgerState ByronBlock) = Void
205207

208+
instance LSM.SerialiseKey Void where
209+
serialiseKey = absurd
210+
deserialiseKey = error "deserialiseKey: Void"
211+
212+
deriving via LSM.ResolveViaSemigroup Void instance LSM.ResolveValue Void
213+
214+
instance LSMOrder (LedgerState ByronBlock) where
215+
toLSMOrder _ [] = []
216+
toLSMOrder _ (x : _) = absurd x
217+
206218
instance LedgerTablesAreTrivial (LedgerState ByronBlock) where
207219
convertMapKind (ByronLedgerState x y z) = ByronLedgerState x y z
208220
instance LedgerTablesAreTrivial (Ticked (LedgerState ByronBlock)) where

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

Lines changed: 25 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -39,14 +39,17 @@ import Codec.CBOR.Decoding
3939
import Codec.CBOR.Encoding
4040
import qualified Data.Map as Map
4141
import Data.MemPack
42+
import qualified Data.Primitive.ByteArray as PBA
4243
import Data.Proxy
4344
import Data.SOP.BasicFunctors
4445
import Data.SOP.Functors
4546
import Data.SOP.Index
4647
import Data.SOP.Strict
4748
import qualified Data.SOP.Tails as Tails
4849
import qualified Data.SOP.Telescope as Telescope
50+
import Data.Vector.Primitive (Vector (..))
4951
import Data.Void
52+
import qualified Database.LSMTree as LSM
5053
import GHC.Generics (Generic)
5154
import Lens.Micro
5255
import NoThunks.Class
@@ -63,6 +66,7 @@ import Ouroboros.Consensus.Shelley.Ledger
6366
, ShelleyCompatible
6467
, shelleyLedgerState
6568
)
69+
import Ouroboros.Consensus.Storage.LedgerDB.V2.LSM
6670
import Ouroboros.Consensus.TypeFamilyWrappers
6771
import Ouroboros.Consensus.Util.IndexedMemPack
6872

@@ -74,7 +78,7 @@ instance
7478
{ getCardanoTxIn :: SL.TxIn
7579
}
7680
deriving stock (Show, Eq, Ord)
77-
deriving newtype NoThunks
81+
deriving newtype (NoThunks, LSM.SerialiseKey)
7882

7983
injectCanonicalTxIn IZ byronTxIn = absurd byronTxIn
8084
injectCanonicalTxIn (IS idx) shelleyTxIn = case idx of
@@ -112,13 +116,30 @@ data CardanoTxOut c
112116
deriving stock (Show, Eq, Generic)
113117
deriving anyclass NoThunks
114118

119+
-- TODO
120+
instance CardanoHardForkConstraints c => LSM.SerialiseValue (CardanoTxOut c) where
121+
serialiseValue txout =
122+
let barr =
123+
indexedPackByteArray
124+
False
125+
(undefined :: (LedgerState (HardForkBlock (CardanoEras c)) EmptyMK)) -- unused
126+
txout
127+
in LSM.RawBytes (Vector 0 (PBA.sizeofByteArray barr) barr)
128+
deserialiseValue (LSM.RawBytes (Vector _ _ barr)) =
129+
indexedUnpackError (undefined :: (LedgerState (HardForkBlock (CardanoEras c)) EmptyMK)) barr
130+
131+
instance CardanoHardForkConstraints c => LSM.ResolveValue (CardanoTxOut c) where
132+
resolve = undefined
133+
134+
instance LSMOrder (LedgerState (HardForkBlock (CardanoEras c))) where
135+
toLSMOrder _ = undefined
136+
115137
-- | Eliminate the wrapping of CardanoTxOut with the provided function. Similar
116138
-- to 'hcimap' on an 'NS'.
117139
eliminateCardanoTxOut ::
118140
forall r c.
119141
CardanoHardForkConstraints c =>
120142
( forall x.
121-
-- TODO ProtoCrypto constraint should be in IsShelleyBlock
122143
IsShelleyBlock x =>
123144
Index (CardanoEras c) x ->
124145
TxOut (LedgerState x) ->
@@ -181,6 +202,8 @@ instance
181202
:* (Fn $ const $ Comp $ K . ConwayTxOut <$> unpackM)
182203
:* Nil
183204
)
205+
-- TODO, we can extract the tip before this function! The class would be
206+
-- IndexedMemPack (NS (Flip LedgerState EmptyMK) (CardanoEras c)) (CardanoTxOut c)
184207
hcollapse <$> (hsequence' $ hap np $ Telescope.tip idx)
185208

186209
instance

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

Lines changed: 38 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -96,13 +96,19 @@ import Codec.Serialise (decode, encode)
9696
import Control.Arrow (left, second)
9797
import qualified Control.Exception as Exception
9898
import Control.Monad.Except
99+
import Control.Monad.Trans.Fail
99100
import qualified Control.State.Transition.Extended as STS
101+
import qualified Data.Array.Byte as BA
100102
import Data.Coerce (coerce)
101103
import Data.Functor.Identity
104+
import qualified Data.List as L
102105
import Data.MemPack
106+
import Data.Primitive.ByteArray as PBA
103107
import qualified Data.Text as T
104108
import qualified Data.Text as Text
109+
import Data.Vector.Primitive (Vector (..))
105110
import Data.Word
111+
import qualified Database.LSMTree as LSM
106112
import GHC.Generics (Generic)
107113
import Lens.Micro
108114
import Lens.Micro.Extras (view)
@@ -130,6 +136,7 @@ import Ouroboros.Consensus.Shelley.Protocol.Abstract
130136
, mkHeaderView
131137
)
132138
import Ouroboros.Consensus.Storage.LedgerDB
139+
import Ouroboros.Consensus.Storage.LedgerDB.V2.LSM
133140
import Ouroboros.Consensus.Util.CBOR
134141
( decodeWithOrigin
135142
, encodeWithOrigin
@@ -320,6 +327,37 @@ instance ShelleyCompatible proto era => UpdateLedger (ShelleyBlock proto era)
320327
type instance TxIn (LedgerState (ShelleyBlock proto era)) = SL.TxIn
321328
type instance TxOut (LedgerState (ShelleyBlock proto era)) = Core.TxOut era
322329

330+
newtype LSMTxIn = LSMTxIn {lsmTxIn :: SL.TxIn}
331+
332+
instance MemPack LSMTxIn where
333+
packedByteCount = packedByteCount . lsmTxIn
334+
packM (LSMTxIn (SL.TxIn txid txix)) = packM txix >> packM txid
335+
unpackM = do
336+
txix <- unpackM
337+
txid <- unpackM
338+
pure . LSMTxIn $ SL.TxIn txid txix
339+
340+
instance LSM.SerialiseKey SL.TxIn where
341+
serialiseKey txin =
342+
let barr = pack $ LSMTxIn txin
343+
in LSM.RawBytes (Vector 0 (PBA.sizeofByteArray barr) barr)
344+
deserialiseKey (LSM.RawBytes (Vector _ _ barr)) = lsmTxIn . unpackError $ barr
345+
346+
instance LSMOrder (LedgerState (ShelleyBlock proto era)) where
347+
toLSMOrder _ =
348+
L.sortBy
349+
( \(SL.TxIn id1 ix1) (SL.TxIn id2 ix2) ->
350+
case compare ix1 ix2 of
351+
EQ -> compare id1 id2
352+
x -> x
353+
)
354+
355+
-- instance (txout ~ Core.TxOut era, MemPack txout) => LSM.SerialiseValue txout where
356+
-- serialiseValue txout =
357+
-- let barr = pack txout
358+
-- in LSM.RawBytes (Vector 0 (PBA.sizeofByteArray barr) barr)
359+
-- deserialiseValue (LSM.RawBytes (Vector _ _ barr)) = unpackError barr
360+
323361
instance
324362
(txout ~ Core.TxOut era, MemPack txout) =>
325363
IndexedMemPack (LedgerState (ShelleyBlock proto era) EmptyMK) txout

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

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -26,10 +26,12 @@ module Ouroboros.Consensus.Shelley.Node
2626
, validateGenesis
2727
) where
2828

29+
import Cardano.Ledger.Core as Core
2930
import qualified Cardano.Ledger.Shelley.API as SL
3031
import Cardano.Protocol.Crypto (Crypto)
3132
import Data.Map.Strict (Map)
3233
import qualified Data.Map.Strict as Map
34+
import Database.LSMTree as LSM
3335
import Ouroboros.Consensus.Block
3436
import Ouroboros.Consensus.Config
3537
import Ouroboros.Consensus.Ledger.SupportsMempool (TxLimits)
@@ -121,5 +123,7 @@ instance
121123
, TxLimits (ShelleyBlock proto era)
122124
, SerialiseNodeToClientConstraints (ShelleyBlock proto era)
123125
, Crypto (ProtoCrypto proto)
126+
, LSM.SerialiseValue (Core.TxOut era)
127+
, LSM.ResolveValue (Core.TxOut era)
124128
) =>
125129
RunNode (ShelleyBlock proto era)

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

Lines changed: 10 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -64,6 +64,7 @@ import qualified Data.Text as T (pack)
6464
import Data.Typeable
6565
import Data.Void (Void)
6666
import Data.Word
67+
import qualified Database.LSMTree as LSM
6768
import Lens.Micro ((^.))
6869
import NoThunks.Class
6970
import Ouroboros.Consensus.Block
@@ -92,6 +93,7 @@ import Ouroboros.Consensus.Shelley.Ledger
9293
import Ouroboros.Consensus.Shelley.Ledger.Inspect as Shelley.Inspect
9394
import Ouroboros.Consensus.Shelley.Node ()
9495
import Ouroboros.Consensus.Shelley.Protocol.Abstract (ProtoCrypto)
96+
import Ouroboros.Consensus.Storage.LedgerDB.V2.LSM
9597
import Ouroboros.Consensus.TypeFamilyWrappers
9698
import Ouroboros.Consensus.Util.IndexedMemPack
9799

@@ -168,6 +170,8 @@ instance
168170
, LedgerSupportsProtocol (ShelleyBlock proto era)
169171
, TxLimits (ShelleyBlock proto era)
170172
, Crypto (ProtoCrypto proto)
173+
, LSM.SerialiseValue (SL.TxOut era)
174+
, LSM.ResolveValue (SL.TxOut era)
171175
) =>
172176
SerialiseHFC '[ShelleyBlock proto era]
173177

@@ -429,15 +433,19 @@ instance
429433
{ getShelleyBlockHFCTxIn :: SL.TxIn
430434
}
431435
deriving stock (Show, Eq, Ord)
432-
deriving newtype NoThunks
436+
deriving newtype (NoThunks, MemPack, LSM.SerialiseKey)
433437

434438
injectCanonicalTxIn IZ txIn = ShelleyBlockHFCTxIn txIn
435439
injectCanonicalTxIn (IS idx') _ = case idx' of {}
436440

437441
ejectCanonicalTxIn IZ txIn = getShelleyBlockHFCTxIn txIn
438442
ejectCanonicalTxIn (IS idx') _ = case idx' of {}
439443

440-
deriving newtype instance MemPack (CanonicalTxIn '[ShelleyBlock proto era])
444+
instance LSMOrder (LedgerState (HardForkBlock '[ShelleyBlock proto era])) where
445+
toLSMOrder _ =
446+
map ShelleyBlockHFCTxIn
447+
. toLSMOrder (Proxy @(LedgerState (ShelleyBlock proto era)))
448+
. map getShelleyBlockHFCTxIn
441449

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

‎ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Serialisation/Common.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -105,6 +105,7 @@ import Ouroboros.Consensus.Ledger.Query
105105
import Ouroboros.Consensus.Ledger.Tables
106106
import Ouroboros.Consensus.Node.NetworkProtocolVersion
107107
import Ouroboros.Consensus.Node.Run
108+
import Ouroboros.Consensus.Storage.LedgerDB.V2.LSM
108109
import Ouroboros.Consensus.Storage.Serialisation
109110
import Ouroboros.Consensus.TypeFamilyWrappers
110111
import Ouroboros.Network.Block (Serialised)
@@ -201,6 +202,7 @@ class
201202
-- defined, but we need to require this instances for any instantiation.
202203
HasLedgerTables (LedgerState (HardForkBlock xs))
203204
, SerializeTablesWithHint (LedgerState (HardForkBlock xs))
205+
, GoodForLSM (LedgerState (HardForkBlock xs))
204206
) =>
205207
SerialiseHFC xs
206208
where

‎ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Run.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -42,6 +42,7 @@ import Ouroboros.Consensus.Storage.ChainDB
4242
, VolatileDbSerialiseConstraints
4343
)
4444
import Ouroboros.Consensus.Storage.LedgerDB
45+
import Ouroboros.Consensus.Storage.LedgerDB.V2.LSM
4546
import Ouroboros.Consensus.Storage.Serialisation
4647
import Ouroboros.Consensus.Util (ShowProxy)
4748
import Ouroboros.Network.Block (Serialised)
@@ -120,6 +121,7 @@ class
120121
, ShowProxy (TxId (GenTx blk))
121122
, (forall fp. ShowQuery (BlockQuery blk fp))
122123
, LedgerSupportsLedgerDB blk
124+
, GoodForLSM (LedgerState blk)
123125
) =>
124126
RunNode blk
125127

‎ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2.hs‎

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -33,7 +33,6 @@ import Data.Set (Set)
3333
import qualified Data.Set as Set
3434
import Data.Traversable (for)
3535
import Data.Tuple (Solo (..))
36-
import Data.Void
3736
import Data.Word
3837
import GHC.Generics
3938
import NoThunks.Class

0 commit comments

Comments
 (0)