Further integration

Author: jasagredo

cabal.project

@@ -25,7 +25,6 @@ packages:
   ouroboros-consensus-diffusion
   sop-extras
   strict-sop-core
-  ../lsm-tree
 
 -- We want to always build the test-suites and benchmarks
 tests: true
@@ -119,7 +118,7 @@ source-repository-package
 source-repository-package
   type: git
   location: https://github.com/jasagredo/lsm-tree
-  tag: fa0d862b7a609473538a0007bd0df314cd2fa635
+  tag: 55c4b99e3e569c168de38f6d351507236d027f49
   subdir:
-
+    .
     blockio

ouroboros-consensus-cardano/app/snapshot-converter.hs

@@ -200,7 +200,7 @@ load config@Config{inpath = pathToDiskSnapshot -> Just (fs@(SomeHasFS hasFS), pa
       checkSnapshotFileStructure Mem path fs
       (ls, _) <- withExceptT SnapshotError $ V2.loadSnapshot nullTracer rr ccfg fs ds
       let h = V2.currentHandle ls
-      (V2.state h,) <$> Trans.lift (V2.readAll (V2.tables h))
+      (V2.state h,) <$> Trans.lift (V2.readAll (V2.tables h) (V2.state h))
     LMDB -> do
       checkSnapshotFileStructure LMDB path fs
       ((dbch, k, bstore), _) <-

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

@@ -175,7 +175,6 @@ library
     sop-extras ^>=0.4,
     strict-sop-core ^>=0.1,
     primitive,
-    FailT,
     text,
     these ^>=1.2,
     validation,
@@ -403,6 +402,7 @@ library unstable-cardano-testlib
 
   build-depends:
     QuickCheck,
+    lsm-tree,
     base,
     cardano-crypto-class,
     cardano-crypto-wrapper,

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

@@ -11,6 +11,7 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Ouroboros.Consensus.Byron.ByronHFC
@@ -294,7 +295,7 @@ instance HasCanonicalTxIn '[ByronBlock] where
     { getByronHFCTxIn :: Void
     }
     deriving stock (Show, Eq, Ord)
-    deriving newtype (NoThunks, MemPack, LSM.SerialiseKey, LSM.SerialiseValue, LSM.ResolveValue)
+    deriving newtype (NoThunks, MemPack, LSM.SerialiseKey)
 
   injectCanonicalTxIn IZ key = absurd key
   injectCanonicalTxIn (IS idx') _ = case idx' of {}
@@ -313,9 +314,13 @@ deriving via
   instance
     IndexedMemPack (LedgerState (HardForkBlock '[ByronBlock]) EmptyMK) Void
 
-instance LSMOrder (LedgerState (HardForkBlock '[ByronBlock])) where
-  toLSMOrder _ [] = []
-  toLSMOrder _ (x : _) = absurd . getByronHFCTxIn $ x
+type instance
+  LSMTxOut (LedgerState (HardForkBlock '[ByronBlock])) =
+    TxOut (LedgerState (HardForkBlock '[ByronBlock]))
+
+instance ToLSMTxOut (LedgerState (HardForkBlock '[ByronBlock])) where
+  toLSMTxOut _ = id
+  fromLSMTxOut _ = id
 
 instance BlockSupportsHFLedgerQuery '[ByronBlock] where
   answerBlockQueryHFLookup IZ _cfg (q :: BlockQuery ByronBlock QFLookupTables result) _dlv = case q of {}

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

@@ -14,6 +14,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 -- | Instances requires for consensus/ledger integration
@@ -70,8 +71,7 @@ import qualified Control.State.Transition.Extended as STS
 import Data.ByteString (ByteString)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
-import Data.Void (Void, absurd)
-import qualified Database.LSMTree as LSM
+import Data.Void (Void)
 import GHC.Generics (Generic)
 import NoThunks.Class (NoThunks)
 import Ouroboros.Consensus.Block
@@ -204,16 +204,11 @@ instance IsLedger (LedgerState ByronBlock) where
 
 type instance TxIn (LedgerState ByronBlock) = Void
 type instance TxOut (LedgerState ByronBlock) = Void
+type instance LSMTxOut (LedgerState ByronBlock) = TxOut (LedgerState ByronBlock)
 
-instance LSM.SerialiseKey Void where
-  serialiseKey = absurd
-  deserialiseKey = error "deserialiseKey: Void"
-
-deriving via LSM.ResolveViaSemigroup Void instance LSM.ResolveValue Void
-
-instance LSMOrder (LedgerState ByronBlock) where
-  toLSMOrder _ [] = []
-  toLSMOrder _ (x : _) = absurd x
+instance ToLSMTxOut (LedgerState ByronBlock) where
+  toLSMTxOut _ = id
+  fromLSMTxOut _ = id
 
 instance LedgerTablesAreTrivial (LedgerState ByronBlock) where
   convertMapKind (ByronLedgerState x y z) = ByronLedgerState x y z

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

@@ -4,6 +4,7 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE EmptyCase #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
@@ -13,6 +14,7 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -116,23 +118,20 @@ data CardanoTxOut c
   deriving stock (Show, Eq, Generic)
   deriving anyclass NoThunks
 
--- TODO
-instance CardanoHardForkConstraints c => LSM.SerialiseValue (CardanoTxOut c) where
-  serialiseValue txout =
-    let barr =
-          indexedPackByteArray
-            False
-            (undefined :: (LedgerState (HardForkBlock (CardanoEras c)) EmptyMK)) -- unused
-            txout
-     in LSM.RawBytes (Vector 0 (PBA.sizeofByteArray barr) barr)
-  deserialiseValue (LSM.RawBytes (Vector _ _ barr)) =
-    indexedUnpackError (undefined :: (LedgerState (HardForkBlock (CardanoEras c)) EmptyMK)) barr
+type instance LSMTxOut (LedgerState (CardanoBlock c)) = LSM.RawBytes
+
+instance LSM.SerialiseValue LSM.RawBytes where
+  serialiseValue = id
+  deserialiseValue = id
 
-instance CardanoHardForkConstraints c => LSM.ResolveValue (CardanoTxOut c) where
-  resolve = undefined
+deriving via LSM.ResolveAsFirst LSM.RawBytes instance LSM.ResolveValue LSM.RawBytes
 
-instance LSMOrder (LedgerState (HardForkBlock (CardanoEras c))) where
-  toLSMOrder _ = undefined
+instance CardanoHardForkConstraints c => ToLSMTxOut (LedgerState (CardanoBlock c)) where
+  toLSMTxOut _ txout =
+    let barr = eliminateCardanoTxOut (const pack) txout
+     in LSM.RawBytes (Vector 0 (PBA.sizeofByteArray barr) barr)
+  fromLSMTxOut st (LSM.RawBytes (Vector _ _ barr)) =
+    indexedUnpackError st barr
 
 -- | Eliminate the wrapping of CardanoTxOut with the provided function. Similar
 -- to 'hcimap' on an 'NS'.

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

@@ -1,11 +1,13 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
@@ -77,11 +79,13 @@ import Control.Monad.Except
 import Control.State.Transition (PredicateFailure)
 import Data.Data (Proxy (Proxy))
 import Data.List.NonEmpty (NonEmpty ((:|)))
+import qualified Database.LSMTree as LSM
 import NoThunks.Class (NoThunks)
 import Ouroboros.Consensus.Ledger.SupportsMempool
   ( WhetherToIntervene (..)
   )
 import Ouroboros.Consensus.Protocol.TPraos (StandardCrypto)
+import Ouroboros.Consensus.Storage.LedgerDB.V2.LSM
 
 {-------------------------------------------------------------------------------
   Eras instantiated with standard crypto
@@ -404,3 +408,34 @@ instance Core.TranslateEra ConwayEra WrapTx where
       . Core.translateEra @ConwayEra ctxt
       . Conway.Tx
       . unwrapTx
+
+{-------------------------------------------------------------------------------
+ SerialiseValue
+-------------------------------------------------------------------------------}
+
+instance LSM.SerialiseValue (SL.ShelleyTxOut ShelleyEra) where
+  serialiseValue = serialiseLSMViaMemPack
+  deserialiseValue = deserialiseLSMViaMemPack
+
+deriving via
+  LSM.ResolveAsFirst (SL.ShelleyTxOut ShelleyEra)
+  instance
+    LSM.ResolveValue (SL.ShelleyTxOut ShelleyEra)
+
+-- instance LSM.SerialiseValue (SL.ShelleyTxOut AllegraEra) where
+--   serialiseValue = serialiseLSMViaMemPack
+--   deserialiseValue = deserialiseLSMViaMemPack
+
+-- deriving via
+--   LSM.ResolveAsFirst (SL.ShelleyTxOut AllegraEra)
+--   instance
+--     LSM.ResolveValue (SL.ShelleyTxOut AllegraEra)
+
+-- instance LSM.SerialiseValue (SL.ShelleyTxOut MaryEra) where
+--   serialiseValue = serialiseLSMViaMemPack
+--   deserialiseValue = deserialiseLSMViaMemPack
+
+-- deriving via
+--   LSM.ResolveAsFirst (SL.ShelleyTxOut MaryEra)
+--   instance
+--     LSM.ResolveValue (SL.ShelleyTxOut MaryEra)

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

@@ -3,6 +3,7 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE DisambiguateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
@@ -96,12 +97,9 @@ import Codec.Serialise (decode, encode)
 import Control.Arrow (left, second)
 import qualified Control.Exception as Exception
 import Control.Monad.Except
-import Control.Monad.Trans.Fail
 import qualified Control.State.Transition.Extended as STS
-import qualified Data.Array.Byte as BA
 import Data.Coerce (coerce)
 import Data.Functor.Identity
-import qualified Data.List as L
 import Data.MemPack
 import Data.Primitive.ByteArray as PBA
 import qualified Data.Text as T
@@ -338,25 +336,16 @@ instance MemPack LSMTxIn where
     pure . LSMTxIn $ SL.TxIn txid txix
 
 instance LSM.SerialiseKey SL.TxIn where
-  serialiseKey txin =
-    let barr = pack $ LSMTxIn txin
-     in LSM.RawBytes (Vector 0 (PBA.sizeofByteArray barr) barr)
-  deserialiseKey (LSM.RawBytes (Vector _ _ barr)) = lsmTxIn . unpackError $ barr
-
-instance LSMOrder (LedgerState (ShelleyBlock proto era)) where
-  toLSMOrder _ =
-    L.sortBy
-      ( \(SL.TxIn id1 ix1) (SL.TxIn id2 ix2) ->
-          case compare ix1 ix2 of
-            EQ -> compare id1 id2
-            x -> x
-      )
+  serialiseKey = serialiseLSMViaMemPack . LSMTxIn
+  deserialiseKey = lsmTxIn . deserialiseLSMViaMemPack
+
+type instance
+  LSMTxOut (LedgerState (ShelleyBlock proto era)) =
+    TxOut (LedgerState (ShelleyBlock proto era))
 
--- instance (txout ~ Core.TxOut era, MemPack txout) => LSM.SerialiseValue txout where
---   serialiseValue txout =
---     let barr = pack txout
---      in LSM.RawBytes (Vector 0 (PBA.sizeofByteArray barr) barr)
---   deserialiseValue (LSM.RawBytes (Vector _ _ barr)) = unpackError barr
+instance ToLSMTxOut (LedgerState (ShelleyBlock proto era)) where
+  toLSMTxOut _ = id
+  fromLSMTxOut _ = id
 
 instance
   (txout ~ Core.TxOut era, MemPack txout) =>

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

@@ -441,11 +441,13 @@ instance
   ejectCanonicalTxIn IZ txIn = getShelleyBlockHFCTxIn txIn
   ejectCanonicalTxIn (IS idx') _ = case idx' of {}
 
-instance LSMOrder (LedgerState (HardForkBlock '[ShelleyBlock proto era])) where
-  toLSMOrder _ =
-    map ShelleyBlockHFCTxIn
-      . toLSMOrder (Proxy @(LedgerState (ShelleyBlock proto era)))
-      . map getShelleyBlockHFCTxIn
+type instance
+  LSMTxOut (LedgerState (HardForkBlock '[ShelleyBlock proto era])) =
+    TxOut (LedgerState (HardForkBlock '[ShelleyBlock proto era]))
+
+instance ToLSMTxOut (LedgerState (HardForkBlock '[ShelleyBlock proto era])) where
+  toLSMTxOut _ = id
+  fromLSMTxOut _ = id
 
 {-------------------------------------------------------------------------------
   HardForkTxOut

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

@@ -67,6 +67,7 @@ import Data.SOP.Strict
 import qualified Data.SOP.Tails as Tails
 import qualified Data.SOP.Telescope as Telescope
 import Data.Void (Void)
+import qualified Database.LSMTree as LSM
 import Lens.Micro ((^.))
 import NoThunks.Class (NoThunks)
 import Ouroboros.Consensus.Block.Forging (BlockForging)
@@ -95,6 +96,7 @@ import Ouroboros.Consensus.Shelley.Ledger
 import Ouroboros.Consensus.Shelley.Node
 import Ouroboros.Consensus.Shelley.Protocol.Abstract (ProtoCrypto)
 import Ouroboros.Consensus.Storage.LedgerDB
+import Ouroboros.Consensus.Storage.LedgerDB.V2.LSM
 import Ouroboros.Consensus.TypeFamilyWrappers
 import Ouroboros.Consensus.Util (eitherToMaybe)
 import Ouroboros.Consensus.Util.IOLike (IOLike)
@@ -513,6 +515,21 @@ deriving newtype instance
   ShelleyBasedHardForkConstraints proto1 era1 proto2 era2 =>
   MemPack (CanonicalTxIn (ShelleyBasedHardForkEras proto1 era1 proto2 era2))
 
+type instance
+  LSMTxOut (LedgerState (HardForkBlock (ShelleyBasedHardForkEras proto1 era1 proto2 era2))) =
+    TxOut (LedgerState (HardForkBlock (ShelleyBasedHardForkEras proto1 era1 proto2 era2)))
+
+instance ToLSMTxOut (LedgerState (HardForkBlock (ShelleyBasedHardForkEras proto1 era1 proto2 era2))) where
+  toLSMTxOut _ = id
+  fromLSMTxOut _ = id
+
+instance
+  ShelleyBasedHardForkConstraints proto1 era1 proto2 era2 =>
+  LSM.SerialiseKey (CanonicalTxIn (ShelleyBasedHardForkEras proto1 era1 proto2 era2))
+  where
+  serialiseKey = serialiseLSMViaMemPack
+  deserialiseKey = deserialiseLSMViaMemPack
+
 instance
   ShelleyBasedHardForkConstraints proto1 era1 proto2 era2 =>
   HasHardForkTxOut (ShelleyBasedHardForkEras proto1 era1 proto2 era2)